Index: LMDZ4/tags/LF_20080728/bld.cfg
===================================================================
--- LMDZ4/tags/LF_20080728/bld.cfg	(revision 984)
+++ LMDZ4/tags/LF_20080728/bld.cfg	(revision 984)
@@ -0,0 +1,84 @@
+# ----------------------- FCM extract configuration file -----------------------
+cfg::type                           bld
+cfg::version                        1.0
+
+
+# ------------------------------------------------------------------------------
+# Build information
+# ------------------------------------------------------------------------------
+
+#Default value of FPP fortran preprocessor
+%FPP cpp
+
+inc arch.fcm
+inc config.fcm
+
+%CONFIG_NAME       %{ARCH}%SUFF_NAME
+%BASE_CONFIG_PATH  %LIBO/%CONFIG_NAME
+%CONFIG_PATH       %BASE_CONFIG_PATH/.config
+%SRC_PATH          %LIBF
+
+
+src::dyn    %SRC_PATH/%DYN
+src::phys   %SRC_PATH/%PHYS
+src::grid    %SRC_PATH/grid
+src::filtrez %SRC_PATH/filtrez
+src::bibio   %SRC_PATH/bibio
+
+bld::lib::dyn      %DYN
+bld::lib::phys     %PHYS
+bld::lib::grid      grid
+bld::lib::filtrez   filtrez
+bld::lib::bibio     bibio
+
+
+bld::outfile_ext::exe    %SUFF_NAME.e
+bld::target              lib%{DYN}.a lib%{PHYS}.a libgrid.a libfiltrez.a libbibio.a 
+bld::target              %EXEC%SUFF_NAME.e
+bld::exe_dep             %{DYN} %{PHYS} grid filtrez bibio
+
+
+dir::root            %CONFIG_PATH
+dir::lib             %BASE_CONFIG_PATH
+dir::bin             %ROOT_PATH/bin
+
+#search_src           1
+
+bld::tool::fpp       %FPP
+bld::tool::fc        %COMPILER 
+bld::tool::ld        %LINK
+bld::tool::ar        %AR
+bld::tool::make      %MAKE
+bld::tool::fflags    %FFLAGS %INCDIR 
+bld::tool::ldflags   %LD_FLAGS %LIB  
+
+bld::tool::cppflags  %FPP_FLAGS %INCDIR
+bld::tool::fppflags  %FPP_FLAGS %INCDIR
+bld::tool::fppkeys   %CPP_KEY %FPP_DEF
+
+
+# Pre-process code before analysing dependencies
+bld::pp              1
+
+
+# Ignore the following dependencies
+bld::excl_dep        inc::netcdf.inc
+bld::excl_dep        use::netcdf
+bld::excl_dep        h::netcdf.inc
+bld::excl_dep        h::mpif.h
+bld::excl_dep        inc::mpif.h
+bld::excl_dep        use::ioipsl
+bld::excl_dep        use::intersurf
+bld::excl_dep        use::mod_prism_proto
+bld::excl_dep        use::mod_prism_def_partition_proto
+bld::excl_dep        use::mod_prism_get_proto
+bld::excl_dep        use::mod_prism_put_proto
+
+# Don't generate interface files
+bld::tool::geninterface none
+
+# Allow ".inc" as an extension for CPP include files
+bld::infile_ext::inc  CPP::INCLUDE
+
+# extension for module output
+bld::outfile_ext::mod .mod
Index: LMDZ4/tags/LF_20080728/build_gcm
===================================================================
--- LMDZ4/tags/LF_20080728/build_gcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/build_gcm	(revision 984)
@@ -0,0 +1,24 @@
+#!/bin/csh
+
+if ( -f '.lock' ) then
+  echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs'
+  echo "Attendez que la premiere compilation soit terminee pour relancer la suivante."
+  echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs,"
+  echo  vous pouvez continuer en repondant oui.
+  echo "Voulez-vous vraiment continuer?"
+
+  if ( $< == "oui" ) then
+    
+  else
+    exit
+  endif
+else
+  echo "compilation en cours..." > '.lock'
+endif
+
+#set arch=$1
+
+
+fcm build
+
+\rm -f '.lock' 
Index: LMDZ4/tags/LF_20080728/create_make_gcm
===================================================================
--- LMDZ4/tags/LF_20080728/create_make_gcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/create_make_gcm	(revision 984)
@@ -0,0 +1,239 @@
+#!/bin/sh
+#
+# $Header$
+#
+#set -xv
+machine=`hostname`
+os=`uname`
+gcm=`pwd`
+libf=$gcm/libf
+libo=$gcm/libo
+CRAY=0
+if [ "$machine" = "atlas" -o "$machine" = "etoile" -o "$machine" = "axis" ] ; then
+  CRAY=1
+fi
+XNEC=0
+if [ "$machine" = "rhodes" ] ; then
+  XNEC=1
+fi
+X6NEC=0
+if [ "$machine" = "mercure" ] ; then
+  X6NEC=1
+fi
+X8BRODIE=0
+if [ "$machine" = "brodie" ] ; then
+  X8BRODIE=1
+fi
+VPP=0
+if [ "$machine" = "nymphea0" ] ; then
+  VPP=1
+fi
+#
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Definitions de Macros pour Make"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo "# Repertoires :"
+echo
+echo "GCM     = "$gcm
+echo 'LIBF    = $(GCM)/libf'
+if [ "$CRAY" = '0' ] ; then
+#   echo 'LIBO    = $(GCM)/libo/$(MACHINE)'
+   echo 'LIBO    = $(LIBOGCM)/$(MACHINE)'
+else
+   echo 'LIBO    = $(GCM)/libo'
+fi
+#echo 'LOCAL_DIR=$(GCM)'
+#echo $localdir
+echo "LOCAL_DIR=`echo $localdir`"
+echo 'BIBIO    = $(LIBF)/bibio'
+echo "FILTRE   = filtre"
+echo "PHYS  = "
+echo "DYN  = dyn "
+echo 'LIBPHY = $(LIBO)/libphy$(PHYS).a'
+echo 'DIRMAIN=dyn$(DIM)d$(FLAG_PARA)'
+echo 'RM=rm'
+echo
+echo "OPLINK = "
+echo
+echo '# Les differentes librairies pour l"edition des liens:'
+echo
+if ( [ "$XNEC" = '1' ] || [ "$X6NEC" = '1' ] || [ "$X8BRODIE" = '1' ] ) ; then
+  echo 'dyn3d      = $(LIBO)/libsxdyn3d.a $(LIBO)/libsx$(FILTRE).a'
+  echo 'dyn3dpar     = $(LIBO)/libsxdyn3dpar.a $(LIBO)/libsx$(FILTRE).a'
+  echo 'dyn2d      = $(LIBO)/libsxdyn2d.a'
+  echo 'dyn1d      = $(LIBO)/libsxdyn1d.a'
+  echo 'L_DYN      = -lsxdyn$(DIM)d$(FLAG_PARA)'
+  echo 'L_FILTRE   = -lsx$(FILTRE)'
+  echo 'L_PHY = -lsxphy$(PHYS) '
+  echo 'L_BIBIO    = -lsxbibio'
+  echo 'L_ADJNT    ='
+else
+  echo 'dyn3d            = $(LIBO)/libdyn3d.a $(LIBO)/lib$(FILTRE).a'
+  echo 'dyn3dpar      = $(LIBO)/libdyn3dpar.a $(LIBO)/lib$(FILTRE).a'
+  echo 'dyn2d            = $(LIBO)/libdyn2d.a'
+  echo 'dyn1d            = $(LIBO)/libdyn1d.a'
+  echo 'L_DYN      = -ldyn$(DIM)d$(FLAG_PARA)'
+  echo 'L_FILTRE   = -l$(FILTRE)'
+  echo 'L_PHY = -lphy$(PHYS) '
+  echo 'L_BIBIO    = -lbibio'
+  echo 'L_ADJNT    ='
+fi
+
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Option de compilation FORTRAN"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+   echo 'COMPILE = $(F77) $(OPTIM) $(INCLUDE) -c'
+   echo 'COMPILE90 = $(F90) $(OPTIM90) $(INCLUDE) -c'
+   echo 'COMPTRU90 = $(F90) $(OPTIMTRU90) $(INCLUDE) -c'
+   echo "LINK    = $LINK"
+   echo "AR      = $AR"
+echo
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Creation des differents executables"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo "# Executables:"
+echo "# ------------"
+echo
+echo "PROG = code"
+echo
+#echo 'main : chimie $(DYN) bibio phys $(OPTION_DEP) '
+echo 'main : $(DYN) bibio phys $(OPTION_DEP) '
+echo '	cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\'
+echo '	cd $(LOCAL_DIR); \'
+echo '	$(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \'
+echo '	$(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_FILTRE) $(L_PHY) $(L_BIBIO) $(L_DYN) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o '
+echo
+echo 'dyn : $(LIBO)/libdyn$(DIM)d$(FLAG_PARA).a $(FILTRE)$(DIM)d'
+echo
+echo 'phys : $(LIBPHY)'
+echo
+#echo 'chimie : $(LIBO)/libchimie.a'
+echo
+echo 'bibio : $(LIBO)/libbibio.a'
+echo
+echo 'adjnt : $(LIBO)/libadjnt.a'
+echo
+echo '$(FILTRE)3d : $(LIBO)/lib$(FILTRE).a'
+echo
+echo '$(FILTRE)2d :'
+echo
+echo '$(FILTRE)1d :'
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Contenu des differentes bibliotheques"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo
+cd $libf >/dev/null 2>&1
+for diri in ` ls `
+do
+   if [ -d $diri ] ; then
+   if [ "`ls $diri/*.F`" != "" ] || [ "`ls $diri/*.F90`" != "" ]  ; then 
+      cd $diri >/dev/null 2>&1
+      echo
+      listlib=""
+      for i in `ls *.F`
+      do
+         fili=`basename $i .F`
+         test=` (  head $i | grep '      PROGRAM' ) `
+         if [ "$test" = "" ] ; then 
+            listlib=$listlib" "$fili
+         fi
+      done
+      for i in `ls *.F90`
+      do
+         fili=`basename $i .F90`
+         test=` (  head $i | grep '      PROGRAM' ) `
+         if [ "$test" = "" ] ; then
+            listlib=$listlib" "$fili
+         fi 
+      done
+#
+      echo
+      echo
+      echo "#======================================================================="
+      echo "# Contenu de la bibliotheque correspondant au Directory "$diri
+      echo "#======================================================================="
+      echo
+      for fili in $listlib
+      do
+         echo '$(LIBO)/lib'$diri".a : " '$(LIBO)/lib'$diri".a("$fili".o)"
+         echo
+      done
+      echo '.PRECIOUS	: $(LIBO)/lib'$diri'.a'
+      echo
+      echo
+      echo "# Compilation des membres de la bibliotheque lib"$diri".a"
+      echo
+      for fili in $listlib
+      do
+         if [ -f $fili.F90 ] ; then
+           trufile=$fili.F90
+         else
+           trufile=$fili.F
+         fi
+         F90=0 ; egrep -i '^ *use ' $trufile > /dev/null 2>&1 && F90=1
+                 egrep -i '^ *module ' $trufile > /dev/null 2>&1 && F90=1
+                 egrep -i '#include*.inc ' $trufile > /dev/null 2>&1 && F90=1
+         str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$diri/$trufile
+         [ "$fili" = "chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F
+         for stri in ` ( sed -n "/\#include/s/\#include//p" $trufile | sed 's/\"//g' ; egrep -i '^ *use ' $trufile | sed -e 's/,/ /' | awk ' { print $2 } ' ) `
+         do
+            stri=`echo $stri | tr [A-Z] [a-z]`
+            if [ -f $stri ] ; then
+               echo $str1 \\
+               str1='$(LIBF)/'$diri'/'$stri
+            else
+               if [ -f $stri.F ] || [ -f $stri.F90 ] ; then
+                  echo $str1 \\
+                  str1='$(LIBO)/lib'$diri'.a('$stri'.o)'
+               else
+                  for dirinc in dyn3d grid bibio
+                  do
+                     if [ -f ../$dirinc/$stri ] ; then
+                        echo $str1 \\
+                        str1='$(LIBF)/'`cd .. ; ls */$stri | head -1`
+                     fi
+                  done
+               fi
+            fi
+         done
+         echo $str1
+	 if [ "$F90" -eq '0' ] ; then
+           echo '	cd $(LOCAL_DIR); \'
+	   echo '	$(COMPILE) $(LIBF)/'$diri'/'$trufile' ; \'
+	 else
+           echo '	cd $(LOCAL_DIR); \'
+           if [ -f $fili.F90 ] ; then
+	      echo '	$(COMPTRU90) $(LIBF)/'$diri'/'$trufile' ; \'
+           else
+	      echo '	$(COMPILE90) $(LIBF)/'$diri'/'$trufile' ; \'
+           fi
+           MODU=0; egrep -i '^ *module ' $trufile> /dev/null 2>&1 && MODU=1
+            if [ "$MODU" -eq '1' -a "$CRAY" != '1' ] ; then
+              if [ "$os" = 'UNIX_System_V' ] ; then
+                echo '	cp $(MOD_LOC_DIR)/*.$(MOD_SUFFIX) $(LIBO)/ ; \'
+              else
+                echo '	mv $(MOD_LOC_DIR)/'$fili'.$(MOD_SUFFIX) $(LIBO)/'$fili'.$(MOD_SUFFIX) ; \'
+#                echo '	if [ "$(MOD_LOC_DIR)" ne "$(LIBO)" ] ; then mv $(MOD_LOC_DIR)/'*'.$(MOD_SUFFIX) $(LIBO) ; fi ; \'
+              fi
+            fi
+	 fi
+	 if ( [ "$XNEC" -eq '1' ] || [ "$X6NEC" = '1' ] || [ "$X8BRODIE" = '1' ] ) ; then
+           echo '	sxar r $(LIBO)/libsx'$diri'.a '$fili'.o ; \'
+         fi
+         echo '	$(AR) r $(LIBO)/lib'$diri'.a '$fili'.o ; $(RM) '$fili'.o ; \'
+         echo '	cd $(GCM)'
+	 echo
+      done
+#	 
+      echo
+   cd $libf
+   fi
+   fi
+done
Index: LMDZ4/tags/LF_20080728/gcm.def
===================================================================
--- LMDZ4/tags/LF_20080728/gcm.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/gcm.def	(revision 984)
@@ -0,0 +1,70 @@
+#
+# $Header$
+#
+## nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+day_step=480
+## periode pour le pas Matsuno (en pas)
+iperiod=5
+## periode de la dissipation (en pas)
+idissip=15
+## choix de l'operateur de dissipation (star ou  non star )
+lstardis=y
+## nombre d'iterations de l'operateur de dissipation   gradiv
+nitergdiv=1
+## nombre d'iterations de l'operateur de dissipation  nxgradrot
+nitergrot=2
+## nombre d'iterations de l'operateur de dissipation  divgrad            
+niterh=2
+## temps de dissipation des plus petites long.d ondes pour u,v (gradiv)  
+tetagdiv=36000.
+## temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+tetagrot=18000.
+## temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+tetatemp=18000.
+## coefficient pour gamdissip                                            
+coefdis=0.
+## choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog) 
+purmats=n
+## avec ou sans physique                                                 
+##physic=n
+iflag_phys=1
+## periode de la physique (en pas)                                       
+iphysiq=10
+## frequence (en  jours ) de l'ecriture du fichier histphy               
+ecritphy=1
+##  Cycle diurne  ou non                 
+cycle_diurne=y
+##  Soil Model  ou non               
+soil_model=y
+##  Choix ou non  de  New oliq               
+new_oliq=y
+##  Orodr  ou  non   pour l orographie              
+ok_orodr=y
+##  Orolf  ou  non   pour l orographie              
+ok_orolf=y
+##   Si = .T. ,  lecture du fichier limit avec la bonne annee             
+ok_limitvrai=n
+## Nombre  d'appels des routines de rayonnements ( par jour)                 
+nbapp_rad=12
+##  Flag  pour la convection (1 pour LMD, 2 pour Tiedtke, 3 KE, 4 KE vect)
+iflag_con=3
+## longitude en degres du centre du zoom                                 
+clon=0.
+## latitude en degres du centre du zoom                                  
+clat=0.
+## facteur de grossissement du zoom,selon longitude                      
+grossismx=1.0
+## facteur de grossissement du zoom ,selon latitude                      
+grossismy=1.0
+##  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+fxyhypb=y
+## extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+dzoomx=0.0
+## extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+dzoomy=0.0
+##raideur du zoom en  X
+taux=3.
+##raideur du zoom en  Y
+tauy=3.
+##  Fonction  f(y) avec y = Sin(latit.) si = .true. , sinon y = latit.         
+ysinus=y
Index: LMDZ4/tags/LF_20080728/libf/bibio/formcoord.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/formcoord.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/formcoord.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/bibio/initdynav.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/initdynav.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/initdynav.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+c
+c
+      subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt
+     .                     ,nq,fileid)
+
+       USE IOIPSL
+
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL. Initialisation du fichier histoire moyenne.
+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 : frequence d'ecriture
+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   Sortie:
+C      fileid: ID du fichier netcdf cree
+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 "advtrac.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid
+      integer nq
+      integer thoriid, zvertiid
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      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
+      
+      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(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, thoriid, fileid)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sigss', 'Niveaux sigma','Pa',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      write(6,*)'inithistave',tstep
+      call histdef(fileid, 'u', 'vents u scalaires moyennes',
+     .             'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(fileid, 'v', 'vents v scalaires moyennes',
+     .             'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(fileid, 'temp', 'temperature moyennee', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel moyenne', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histdef(fileid, ttext(iq), ttext(iq), '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/bibio/initfluxsto.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/initfluxsto.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/initfluxsto.F	(revision 984)
@@ -0,0 +1,226 @@
+!
+! $Header$
+!
+      subroutine initfluxsto
+     .  (infile,tstep,t_ops,t_wrt,nq,
+     .                    fileid,filevid,filedid)
+
+       USE IOIPSL
+
+      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   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"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 itau
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+      integer nq,ndex(1)
+      real nivd(1)
+
+C   Variables locales
+C
+      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
+	
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/bibio/inithist.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/inithist.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/inithist.F	(revision 984)
@@ -0,0 +1,185 @@
+!
+! $Header$
+!
+      subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,nq,fileid,
+     .                    filevid)
+
+       USE IOIPSL
+
+      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   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 "advtrac.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq
+
+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
+      
+      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('dyn_histv.nc', iip1, rlong(:,1), jjm, rlat(1,:),
+     .             1, iip1, 1, jjm,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+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','-',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      call histdef(fileid, 'ucov', 'vents u covariants', 'm/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      call histdef(filevid, 'vcov', 'vents v covariants', 'm/s',
+     .             iip1, jjm, vhoriid, 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  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histdef(fileid, 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(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/bibio/lnblnk.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/lnblnk.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/lnblnk.F	(revision 984)
@@ -0,0 +1,39 @@
+!
+! $Header$
+!
+      INTEGER FUNCTION lnblnk (letter)
+
+C--------------------------------------------------------
+C Fonction qui determine la longeur d'un string sans les
+C blancs qui suivent. Le critere pour determiner la fin du
+C string est, trois blancs de suite
+C---------------------------------------------------------
+C     ARGUMENTS
+C     +++++++++
+C     letter: CHARACTER*xxx (xxx < imax)
+C             le string dont on determine la longuer
+C     lnblnk: INTEGER
+C             le nombre de characteres
+C
+C     PARAMETER
+C     +++++++++
+C     imax : INTEGER
+C            le nombre maximale de character que peut contenir le string
+C            a traiter
+
+      IMPLICIT NONE
+      INTEGER i,imax
+      PARAMETER (imax = 256)
+      CHARACTER*256 letter
+
+      i=0
+
+10    i=i+1
+      IF (letter(i:i+3) . EQ . '   ') GOTO 20
+      GOTO 10
+
+20    lnblnk=i-1
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/bibio/misc_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/misc_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/misc_mod.F90	(revision 984)
@@ -0,0 +1,6 @@
+module misc_mod
+  integer,save :: itaumax
+  logical,save :: adjust
+  integer,save :: ItCount
+  logical,save :: debug
+end module misc_mod 
Index: LMDZ4/tags/LF_20080728/libf/bibio/vampir.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/vampir.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/vampir.F90	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/bibio/write_field.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/write_field.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/write_field.F90	(revision 984)
@@ -0,0 +1,328 @@
+!
+! $Header$
+!
+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)
+    USE ioipsl
+    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)
+    USE ioipsl
+    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: LMDZ4/tags/LF_20080728/libf/bibio/writedynav.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/writedynav.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/writedynav.F	(revision 984)
@@ -0,0 +1,142 @@
+!
+! $Header$
+!
+      subroutine writedynav( histid, nq, time, vcov, 
+     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
+
+      USE ioipsl
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      nqmx: nombre maxi de traceurs
+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   Sortie:
+C      fileid: ID du fichier netcdf cree
+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 "advtrac.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, nq
+      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,nq)
+      integer time
+
+
+C   Variables locales
+C
+      integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
+      real us(ip1jmp1*llm), vs(ip1jmp1*llm)
+      real tm(ip1jmp1*llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) 
+      logical ok_sync
+      integer itau_w
+C
+C  Initialisations
+C
+      ndex3d = 0
+      ndex2d = 0
+      ok_sync = .TRUE.
+      us = 999.999
+      vs = 999.999
+      tm = 999.999
+      vnat = 999.999
+      unat = 999.999
+      itau_w = itau_dyn + time
+
+C 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 scalaire
+C
+      call gr_u_scal(llm, unat, us)
+      call histwrite(histid, 'u', itau_w, us, 
+     .               iip1*jjp1*llm, ndex3d)
+C
+C  Vents V scalaire
+C
+      call gr_v_scal(llm, vnat, vs)
+      call histwrite(histid, 'v', itau_w, vs, 
+     .               iip1*jjp1*llm, ndex3d)
+C
+C  Temperature potentielle moyennee
+C
+      call histwrite(histid, 'theta', itau_w, teta, 
+     .                iip1*jjp1*llm, ndex3d)
+C
+C  Temperature moyennee
+C
+      do ii = 1, ijp1llm
+        tm(ii) = teta(ii) * ppk(ii)/cpp
+      enddo
+      call histwrite(histid, 'temp', itau_w, tm, 
+     .                iip1*jjp1*llm, ndex3d)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi, 
+     .                iip1*jjp1*llm, ndex3d)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histwrite(histid, ttext(iq), itau_w, q(:,:,iq), 
+     .                   iip1*jjp1*llm, ndex3d)
+        enddo
+C
+C  Masse
+C
+       call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d)
+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) call histsync(histid)
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/bibio/writehist.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/bibio/writehist.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/bibio/writehist.F	(revision 984)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+      subroutine writehist( histid, histvid, nq, time, vcov, 
+     ,                          ucov,teta,phi,q,masse,ps,phis)
+
+      USE ioipsl
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      histvid:ID du fichier histoire pour les vents V (appele a disparaitre)
+C      nqmx: nombre maxi de traceurs
+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   Sortie:
+C      fileid: ID du fichier netcdf cree
+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 "advtrac.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, nq, histvid
+      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,nq)
+      integer time
+
+
+C   Variables locales
+C
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+      logical ok_sync
+      integer itau_w
+C
+C  Initialisations
+C
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
+      ok_sync =.TRUE.
+      itau_w = itau_dyn + time
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      call histwrite(histid, 'ucov', itau_w, ucov, 
+     .               iip1*jjp1*llm, ndexu)
+
+C
+C  Vents V
+C
+      call histwrite(histvid, 'vcov', itau_w, vcov, 
+     .               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,nq
+          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, ndex2d)
+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)
+      endif
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/PVtheta.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/PVtheta.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/PVtheta.F	(revision 984)
@@ -0,0 +1,196 @@
+      SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta,
+     $           ztfi,zplay,zplev,
+     $           nbteta,theta,PVteta)
+      IMPLICIT none
+
+c=======================================================================
+c
+c   Auteur:  I. Musat
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    Calcul de la vorticite potentielle PVteta sur des iso-theta selon
+c    la methodologie du NCEP/NCAR :
+c    1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les
+c       niveaux du modele => N2
+c    2) on interpole les vents, la temperature et le N**2 sur des isentropes
+c       (en fait sur des iso-theta) lineairement en log(theta) =>
+c       ucovteta, vcovteta, N2teta
+c    3) on calcule la vorticite absolue sur des iso-theta => vorateta
+c    4) on calcule la densite rho sur des iso-theta => rhoteta 
+c
+c       rhoteta = (T/theta)**(cp/R)*p0/(R*T)
+c
+c    5) on calcule la vorticite potentielle sur des iso-theta => PVteta
+c
+c       PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU
+c
+c       NB: 1PVU=10**(-6) K*m**2/(s * kg)
+c
+c       PVteta =  vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s)
+c
+c
+c    *******************************************************************
+c
+c
+c     Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta
+c                       -> sur la grille dynamique
+c     Variable de sortie : PVteta
+c                       -> sur la grille physique 
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+c
+c variables Input
+c
+      INTEGER ilon, ilev
+      REAL pvcov(iip1,jjm,ilev)
+      REAL pucov(iip1,jjp1,ilev)
+      REAL pteta(iip1,jjp1,ilev)
+      REAL ztfi(ilon,ilev)
+      REAL zplay(ilon,ilev), zplev(ilon,ilev+1)
+      INTEGER nbteta
+      REAL theta(nbteta)
+c
+c variable Output
+c
+      REAL PVteta(ilon,nbteta)
+c
+c variables locales
+c
+      INTEGER i, j, l, ig0
+      REAL SSUM
+      REAL teta(ilon, ilev)
+      REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev)
+      REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev)
+      REAL N2(ilon,ilev-1), N2teta(ilon,nbteta)
+      REAL ztfiteta(ilon,nbteta)
+      REAL rhoteta(ilon,nbteta)
+      REAL vorateta(iip1,jjm,nbteta)
+      REAL voratetafi(ilon,nbteta), vorpol(iim)
+c
+#include "comgeom2.h"
+#include "comconst.h"
+#include "comvert.h"
+c
+c projection teta sur la grille physique
+c
+      DO l=1,llm
+       teta(1,l)   =  pteta(1,1,l)
+       ig0         = 2
+       DO j = 2, jjm
+        DO i = 1, iim
+         teta(ig0,l)    = pteta(i,j,l)
+         ig0            = ig0 + 1
+        ENDDO
+       ENDDO
+       teta(ig0,l)    = pteta(1,jjp1,l)
+      ENDDO
+c
+c calcul pteta sur les grilles U et V
+c
+      DO l=1, llm
+       DO j=1, jjp1
+        DO i=1, iip1
+         ig0=i+(j-1)*iip1
+         ptetau(ig0,l)=pteta(i,j,l)
+        ENDDO !i
+       ENDDO !j
+       DO j=1, jjm
+        DO i=1, iip1
+         ig0=i+(j-1)*iip1
+         ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l))
+        ENDDO !i
+       ENDDO !j
+      ENDDO !l
+c
+c projection pucov, pvcov sur une surface de theta constante
+c
+      DO l=1, nbteta
+cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l),
+       CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l),
+     .                pucov,ucovteta(:,l))
+cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l),
+       CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l),
+     .                pvcov,vcovteta(:,l))
+      ENDDO !l
+c
+c calcul vorticite absolue sur une iso-theta : vorateta
+c
+      CALL tourabs(nbteta,vcovteta,ucovteta,vorateta)
+c
+c projection vorateta sur la grille physique => voratetafi
+c
+      DO l=1,nbteta
+       DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+         voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) +
+     $                           vorateta(i+1,j-1,l) * alpha1(i+1,j) +
+     $                           vorateta(i  ,j  ,l) * alpha3(i+1,j) +
+     $                           vorateta(i+1,j  ,l) * alpha2(i+1,j)
+        ENDDO
+        voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l)
+       ENDDO
+      ENDDO
+c
+      DO l=1,nbteta
+       DO i=1,iim
+        vorpol(i)  = vorateta(i,1,l)*aire(i,1)
+       ENDDO
+       voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln
+      ENDDO
+c
+      DO l=1,nbteta
+       DO i=1,iim
+        vorpol(i)  = vorateta(i,jjm,l)* aire(i,jjm +1)
+       ENDDO
+       voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols
+      ENDDO
+c 
+c calcul N**2 sur la grille physique => N2
+c
+      DO l=1, llm-1 
+       DO i=1, ilon
+        N2(i,l) = (g**2 * zplay(i,l) * 
+     $            (ztfi(i,l+1)-ztfi(i,l)) )/
+     $            (R*ztfi(i,l)*ztfi(i,l)*
+     $            (zplev(i,l)-zplev(i,l+1)) )+
+     $            (g**2)/(ztfi(i,l)*CPP)
+       ENDDO !i
+      ENDDO !l
+c
+c calcul N2 sur une iso-theta => N2teta 
+c
+      DO l=1, nbteta
+       CALL tetalevel(ilon,llm-1,.true.,teta,theta(l),
+     $                N2,N2teta(:,l))
+       CALL tetalevel(ilon,llm,.true.,teta,theta(l),
+     $                ztfi,ztfiteta(:,l))
+      ENDDO !l=1, nbteta
+c
+c calcul rho et PV sur une iso-theta : rhoteta, PVteta
+c
+      DO l=1, nbteta
+       DO i=1, ilon
+        rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)*
+     $  (preff/(R*ztfiteta(i,l)))
+c
+c PVteta en PVU
+c
+        PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/
+     $              (g**2*rhoteta(i,l))
+c
+c PVteta en 1/(Pa*s)
+c
+        PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/
+     $              (g**2*rhoteta(i,l))
+       ENDDO !i
+      ENDDO !l
+c
+      RETURN
+      END 
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/abort_gcm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/abort_gcm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/abort_gcm.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+#include "iniprint.h"
+ 
+C
+C Stops the simulation cleanly, closing files and printing various
+C comments
+C
+C  Input: modname = name of calling program
+C         message = stuff to print
+C         ierr    = severity of situation ( = 0 normal )
+
+      character*20 modname
+      integer ierr
+      character*80 message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+      call histclo
+      call restclo
+#endif
+c     call getin_dump
+c     call histclo(2)
+c     call histclo(3)
+c     call histclo(4)
+c     call histclo(5)
+      write(lunout,*) 'Stopping in ', modname
+      write(lunout,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+      endif
+      STOP
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/academic.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/academic.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/academic.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      real tetarappel(ip1jmp1,llm),taurappel
+      common/academic/tetarappel,taurappel
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/adaptdt.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/adaptdt.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/adaptdt.F	(revision 984)
@@ -0,0 +1,59 @@
+!
+! $Header$
+!
+      subroutine adaptdt(nadv,dtbon,n,pbaru,
+     c                   masse)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+c----------------------------------------------------------
+c     Arguments
+c----------------------------------------------------------
+      INTEGER n,nadv
+      REAL dtbon 
+      REAL pbaru(iip1,jjp1,llm)
+      REAL masse(iip1,jjp1,llm)
+c----------------------------------------------------------    
+c     Local
+c----------------------------------------------------------
+      INTEGER i,j,l
+      REAL CFLmax,aaa,bbb
+      
+        CFLmax=0.
+        do l=1,llm
+         do j=2,jjm
+          do i=1,iim
+             aaa=pbaru(i,j,l)*dtvr/masse(i,j,l)
+             CFLmax=max(CFLmax,aaa)
+             bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l)
+             CFLmax=max(CFLmax,bbb)
+          enddo
+         enddo
+        enddo              
+        n=int(CFLmax)+1
+c pour reproduire cas VL du code qui appele x,y,z,y,x
+c        if (nadv.eq.30) n=n/2   ! Pour Prather
+        dtbon=dtvr/n
+        
+       return
+       end
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/addfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/addfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/addfi.F	(revision 984)
@@ -0,0 +1,167 @@
+!
+! $Header$
+!
+      SUBROUTINE addfi(nq, pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c    Addition of the physical tendencies
+c
+c    Interface :
+c    -----------
+c
+c      Input :
+c      -------
+c      pdt                    time step of integration
+c      leapf                  logical
+c      forward                logical
+c      pucov(ip1jmp1,llm)     first component of the covariant velocity
+c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+c      pteta(ip1jmp1,llm)     potential temperature
+c      pts(ip1jmp1,llm)       surface temperature
+c      pdufi(ip1jmp1,llm)     |
+c      pdvfi(ip1jm,llm)       |   respective
+c      pdhfi(ip1jmp1)         |      tendencies
+c      pdtsfi(ip1jmp1)        |
+c
+c      Output :
+c      --------
+c      pucov
+c      pvcov
+c      ph
+c      pts
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      INTEGER nq
+
+      REAL pdt
+c
+      REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
+      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)
+c
+      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
+      REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
+c
+      LOGICAL leapf,forward
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      PARAMETER ( qtestt = 1.0e-40 )
+
+      REAL SSUM
+c
+c-----------------------------------------------------------------------
+
+      DO k = 1,llm
+         DO j = 1,ip1jmp1
+            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO  k    = 1, llm
+       DO  ij   = 1, iim
+         xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+         xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+       ENDDO
+       tpn      = SSUM(iim,xpn,1)/ apoln
+       tps      = SSUM(iim,xps,1)/ apols
+
+       DO ij   = 1, iip1
+         pteta(   ij   ,k)  = tpn
+         pteta(ij+ip1jm,k)  = tps
+       ENDDO
+      ENDDO
+c
+
+      DO k = 1,llm
+         DO j = iip2,ip1jm
+            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO k = 1,llm
+         DO j = 1,ip1jm
+            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+c
+      DO j = 1,ip1jmp1
+         pps(j) = pps(j) + pdpfi(j) * pdt
+      ENDDO
+ 
+      DO iq = 1, 2
+         DO k = 1,llm
+            DO j = 1,ip1jmp1
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+            ENDDO
+         ENDDO
+      ENDDO
+
+      DO iq = 3, nq
+         DO k = 1,llm
+            DO j = 1,ip1jmp1
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+            ENDDO
+         ENDDO
+      ENDDO
+
+
+      DO  ij   = 1, iim
+        xpn(ij) = aire(   ij   ) * pps(  ij     )
+        xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+      ENDDO
+      tpn      = SSUM(iim,xpn,1)/apoln
+      tps      = SSUM(iim,xps,1)/apols
+
+      DO ij   = 1, iip1
+        pps (   ij     )  = tpn
+        pps ( ij+ip1jm )  = tps
+      ENDDO
+
+
+      DO iq = 1, nq
+        DO  k    = 1, llm
+          DO  ij   = 1, iim
+            xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+            xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+          ENDDO
+          tpn      = SSUM(iim,xpn,1)/apoln
+          tps      = SSUM(iim,xps,1)/apols
+
+          DO ij   = 1, iip1
+            pq (   ij   ,k,iq)  = tpn
+            pq (ij+ip1jm,k,iq)  = tps
+          ENDDO
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advect.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advect.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advect.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l
+
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+      DO  l=1,llm
+         DO    ij     = iip2, ip1jmp1
+            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+         ENDDO
+         DO    ij     = iip2, ip1jm
+            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+         ENDDO
+         DO      ij         = 1, iip1
+            uav(ij      ,l) = 0.
+            uav(ip1jm+ij,l) = 0.
+         ENDDO
+      ENDDO
+
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+
+      DO  l=1,llm
+         DO    ij   = 2, ip1jm
+          vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         DO    ij   = 1,ip1jm,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         DO    ij   = 1, ip1jm-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         DO    ij       = 1, ip1jm, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+c
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+
+      DO 5   ij   = 1, ip1jmp1
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+
+      DO 6 ij = iip2 ,ip1jm-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .....  correction pour  du(iip1,j,l)  ........
+c     .....     du(iip1,j,l)= du(1,j,l)   .....
+
+CDIR$ IVDEP
+      DO   7  ij   = iip1 +iip1, ip1jm, iip1
+      du( ij, l  ) = du( ij -iim, l  )
+      du( ij,l+1 ) = du( ij -iim,l+1 )
+   7  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+
+      DO 8 ij = 1, ip1jm
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+
+        DO 15 ij = 1, ip1jmp1
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta(ij, l ) = dteta(ij, l )  -  ww
+         dteta(ij,l+1) = dteta(ij,l+1)  +  ww
+  15    CONTINUE
+
+      IF( conser)  THEN
+        DO 17 ij = 1,ip1jmp1
+        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+  17    CONTINUE
+        gt       = SSUM( ip1jmp1,ge,1 )
+        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+      END IF
+
+  20  CONTINUE
+ 
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advn.F	(revision 984)
@@ -0,0 +1,983 @@
+!
+! $Header$
+!
+      SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+c
+c   Arguments:
+c   ----------
+      integer mode
+      real masse(ip1jmp1,llm)
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      integer ijlqmin,iqmin,jqmin,lqmin
+      integer ismin
+c
+      real zm(ip1jmp1,llm),newmasse
+      real mu(ip1jmp1,llm)
+      real mv(ip1jm,llm)
+      real mw(ip1jmp1,llm+1)
+      real zq(ip1jmp1,llm),zz,qpn,qps
+      real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm)
+      real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm)
+      real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm)
+      real temps0,temps1,temps2,temps3
+      real ztemps1,ztemps2,ztemps3,ssum
+      logical testcpu
+      save testcpu
+      save temps1,temps2,temps3
+      real zzpbar,zzw
+
+#ifdef CRAY
+      real second
+#endif
+
+      real qmin,qmax
+      data qmin,qmax/0.,1./
+      data testcpu/.false./
+      data temps1,temps2,temps3/0.,0.,0./
+
+      zzpbar = 0.5 * pdt
+      zzw    = pdt
+
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+
+      do l=1,llm
+         qpn=0.
+         qps=0.
+         do ij=1,iim
+            qpn=qpn+q(ij,l)*masse(ij,l)
+            qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l)
+         enddo
+         qpn=qpn/ssum(iim,masse(1,l),1)
+         qps=qps/ssum(iim,masse(ip1jm+1,l),1)
+         do ij=1,iip1
+            q(ij,l)=qpn
+            q(ip1jm+ij,l)=qps
+         enddo
+      enddo
+
+      do ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      enddo
+      do l=1,llm
+         do ij=1,ip1jmp1
+            zq(ij,l)=q(ij,l)
+            zm(ij,l)=masse(ij,l)
+         enddo
+      enddo
+
+c     call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call advnqx(zq,zqg,zqd)
+      call advnx(zq,zqg,zqd,zm,mu,mode)
+      call advnqy(zq,zqs,zqn)
+      call advny(zq,zqs,zqn,zm,mv)
+      call advnqz(zq,zqh,zqb)
+      call advnz(zq,zqh,zqb,zm,mw)
+c     call vlz(zq,0.,zm,mw)
+      call advnqy(zq,zqs,zqn)
+      call advny(zq,zqs,zqn,zm,mv)
+      call advnqx(zq,zqg,zqd)
+      call advnx(zq,zqg,zqd,zm,mu,mode)
+c     call minmaxq(zq,qmin,qmax,'apres vlx     ')
+
+#ifdef CRAY
+      if(testcpu) then
+         ztemps1=second(0.)
+         temps1=temps1+ztemps1-ztemps2
+            print*,'VLSPLT X:',temps1,'   Y:',temps2,'   Z:',temps3
+      endif
+#endif
+      do l=1,llm
+         do ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         enddo
+         do ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         enddo
+      enddo
+
+      RETURN
+      END
+
+      SUBROUTINE advnqx(q,qg,qd)
+c
+c     Auteurs:   Calcul des valeurs de q aux point u.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dxqu(ip1jmp1),zqu(ip1jmp1)
+      real zqmax(ip1jmp1),zqmin(ip1jmp1)
+      logical extremum(ip1jmp1)
+
+      integer mode
+      save mode
+      data mode/1/
+
+c   calcul des pentes en u:
+c   -----------------------
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jm
+               qd(ij,l)=q(ij,l)
+               qg(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+      do l = 1, llm
+         do ij=iip2,ip1jm-1
+            dxqu(ij)=q(ij+1,l)-q(ij,l)
+            zqu(ij)=0.5*(q(ij+1,l)+q(ij,l))
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqu(ij)=dxqu(ij-iim)
+            zqu(ij)=zqu(ij-iim)
+         enddo
+         do ij=iip2,ip1jm-1
+            zqu(ij)=zqu(ij)-dxqu(ij+1)/12.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqu(ij)=zqu(ij-iim)
+         enddo
+         do ij=iip2+1,ip1jm
+            zqu(ij)=zqu(ij)+dxqu(ij-1)/12.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqu(ij-iim)=zqu(ij)
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+
+         do ij=iip2,ip1jm-1
+            zqmax(ij)=max(q(ij+1,l),q(ij,l))
+            zqmin(ij)=min(q(ij+1,l),q(ij,l))
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqmax(ij)=zqmax(ij-iim)
+            zqmin(ij)=zqmin(ij-iim)
+         enddo
+         do ij=iip2+1,ip1jm
+            extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            extremum(ij-iim)=extremum(ij)
+         enddo
+         do ij=iip2,ip1jm
+            zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij))
+         enddo
+         do ij=iip2+1,ip1jm
+            if(extremum(ij)) then
+               qg(ij,l)=q(ij,l)
+               qd(ij,l)=q(ij,l)
+            else
+               qd(ij,l)=zqu(ij)
+               qg(ij,l)=zqu(ij-1)
+            endif
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            qd(ij-iim,l)=qd(ij,l)
+            qg(ij-iim,l)=qg(ij,l)
+         enddo
+
+         goto 8888
+
+         do ij=iip2+1,ip1jm
+            if(extremum(ij).and..not.extremum(ij-1))
+     s         qd(ij-1,l)=q(ij,l)
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            qd(ij-iim,l)=qd(ij,l)
+         enddo
+         do ij=iip2,ip1jm-1
+            if (extremum(ij).and..not.extremum(ij+1))
+     s         qg(ij+1,l)=q(ij,l)
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            qg(ij,l)=qg(ij-iim,l)
+         enddo
+8888     continue
+      enddo
+      endif
+      RETURN
+      END
+      SUBROUTINE advnqy(q,qs,qn)
+c
+c     Auteurs:   Calcul des valeurs de q aux point v.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dyqv(ip1jm),zqv(ip1jm,llm)
+      real zqmax(ip1jm),zqmin(ip1jm)
+      logical extremum(ip1jmp1)
+
+      integer mode
+      save mode
+      data mode/1/
+
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+               qn(ij,l)=q(ij,l)
+               qs(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+
+c   calcul des pentes en u:
+c   -----------------------
+      do l = 1, llm
+         do ij=1,ip1jm
+            dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         enddo
+
+         do ij=iip2,ip1jm-iip1
+            zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l))
+            zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12.
+         enddo
+
+         do ij=iip2,ip1jm
+            extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0.
+         enddo
+
+c Pas de pentes aux poles
+         do ij=1,iip1
+            zqv(ij,l)=q(ij,l)
+            zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l)
+            extremum(ij)=.true.
+            extremum(ip1jmp1-iip1+ij)=.true.
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+         do ij=1,ip1jm
+            zqmax(ij)=max(q(ij+iip1,l),q(ij,l))
+            zqmin(ij)=min(q(ij+iip1,l),q(ij,l))
+         enddo
+
+         do ij=1,ip1jm
+            zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij))
+         enddo
+
+         do ij=iip2,ip1jm
+            if(extremum(ij)) then
+               qs(ij,l)=q(ij,l)
+               qn(ij,l)=q(ij,l)
+c              if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l)
+c              if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l)
+            else
+               qs(ij,l)=zqv(ij,l)
+               qn(ij,l)=zqv(ij-iip1,l)
+            endif
+         enddo
+
+         do ij=1,iip1
+            qs(ij,l)=q(ij,l)
+            qn(ij,l)=q(ij,l)
+            qs(ip1jm+ij,l)=q(ip1jm+ij,l)
+            qn(ip1jm+ij,l)=q(ip1jm+ij,l)
+         enddo
+
+      enddo
+      endif
+      RETURN
+      END
+
+      SUBROUTINE advnqz(q,qh,qb)
+c
+c     Auteurs:   Calcul des valeurs de q aux point v.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1)
+      real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm)
+      logical extremum(ip1jmp1,llm)
+
+      integer mode
+      save mode
+
+      data mode/1/
+
+c   calcul des pentes en u:
+c   -----------------------
+
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+               qb(ij,l)=q(ij,l)
+               qh(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+      do l = 2, llm
+         do ij=1,ip1jmp1
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l))
+         enddo
+      enddo
+      do ij=1,ip1jmp1
+         dzqw(ij,1)=0.
+         dzqw(ij,llm+1)=0.
+      enddo
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12.
+         enddo
+      enddo
+      do l=2,llm-1
+         do ij=1,ip1jmp1
+            extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0.
+         enddo
+      enddo
+
+c Pas de pentes en bas et en haut
+         do ij=1,ip1jmp1
+            zqw(ij,2)=q(ij,1)
+            zqw(ij,llm)=q(ij,llm)
+            extremum(ij,1)=.true.
+            extremum(ij,llm)=.true.
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqmax(ij,l)=max(q(ij,l-1),q(ij,l))
+            zqmin(ij,l)=min(q(ij,l-1),q(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm-1
+         do ij=1,ip1jmp1
+            if(extremum(ij,l)) then
+               qh(ij,l)=q(ij,l)
+               qb(ij,l)=q(ij,l)
+            else
+               qh(ij,l)=zqw(ij,l+1)
+               qb(ij,l)=zqw(ij,l)
+            endif
+         enddo
+      enddo
+c     do l=2,llm-1
+c        do ij=1,ip1jmp1
+c           if(extremum(ij,l)) then
+c              if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l)
+c              if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l)
+c           endif
+c        enddo
+c     enddo
+
+      do ij=1,ip1jmp1
+         qb(ij,1)=q(ij,1)
+         qh(ij,1)=q(ij,1)
+         qb(ij,llm)=q(ij,llm)
+         qh(ij,llm)=q(ij,llm)
+      enddo
+
+      endif
+
+      RETURN
+      END
+
+      SUBROUTINE advnx(q,qg,qd,masse,u_m,mode)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      integer mode
+      real masse(ip1jmp1,llm)
+      real u_m( ip1jmp1,llm )
+      real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq
+      integer n0,nl(llm)
+c
+      real new_m,zu_m,zdq,zz
+      real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig
+      real u_mq(ip1jmp1,llm)
+
+      real zm,zq,zsigm,zsigp,zqm,zqp,zu
+
+      logical ladvplus(ip1jmp1,llm)
+
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+
+      do l=1,llm
+            do ij=iip2,ip1jm
+               zdq=qd(ij,l)-qg(ij,l)
+c              if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l
+c                 print*,qd(ij,l),q(ij,l),qg(ij,l)
+c                 qd(ij,l)=q(ij,l)
+c                 qg(ij,l)=q(ij,l)
+c              endif
+               if(abs(zdq).gt.prec) then
+                  zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq
+                  zsigg(ij,l)=1.-zsigd(ij,l)
+c                 if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and.
+c    s               zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then
+c                    print*,'probleme au point ij=',ij,'  l=',l
+c                    print*,'sigg=',zsigg(ij,l),'  sigd=',zsigd(ij,l)
+c                    print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq
+c                    stop
+c                 endif
+               else
+                  zsigd(ij,l)=0.5
+                  zsigg(ij,l)=0.5
+                  qd(ij,l)=q(ij,l)
+                  qg(ij,l)=q(ij,l)
+               endif
+            enddo
+       enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+       do l=1,llm
+       do ij=iip2,ip1jm-1
+          if (u_m(ij,l).ge.0.) then
+             zsigp=zsigd(ij,l)
+             zsigm=zsigg(ij,l)
+             zqp=qd(ij,l)
+             zqm=qg(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          else
+             zsigm=zsigd(ij+1,l)
+             zsigp=zsigg(ij+1,l)
+             zqm=qd(ij+1,l)
+             zqp=qg(ij+1,l)
+             zm=masse(ij+1,l)
+             zq=q(ij+1,l)
+          endif
+          zu=abs(u_m(ij,l))
+          ladvplus(ij,l)=zu.gt.zm
+          zsig=zu/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (mode.eq.1) then
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*zqp
+             else if (mode.eq.1) then
+                 u_mq(ij,l)=
+     s           sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm)
+             endif 
+          else
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+             else
+                zz=0.5*(zsig-zsigp)/zsigm
+                u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp
+     s          +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+             endif
+          endif
+c         if(zsig.lt.0.) then
+c            print*,'au point ij=',ij,'  l=',l,'  sig=',zsig
+c            stop
+c         endif
+      enddo
+      enddo
+
+      do l=1,llm
+       do ij=iip1+iip1,ip1jm,iip1
+          u_mq(ij,l)=u_mq(ij-iim,l)
+          ladvplus(ij,l)=ladvplus(ij-iim,l)
+       enddo
+      enddo
+
+c=================================================================
+C   SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES
+c=================================================================
+c   tris des regions a traiter
+      n0=0
+      do l=1,llm
+         nl(l)=0
+         do ij=iip2,ip1jm
+            if(ladvplus(ij,l)) then
+               nl(l)=nl(l)+1
+               u_mq(ij,l)=0.
+            endif
+         enddo
+         n0=n0+nl(l)
+      enddo
+
+      if(n0.gt.1) then
+      IF (prt_level > 9) WRITE(lunout,*)
+     & 'Nombre de points pour lesquels on advect plus que le'
+     &       ,'contenu de la maille : ',n0
+
+         do l=1,llm
+            if(nl(l).gt.0) then
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               do ij=iip2,ip1jm
+                  if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then
+                     iju=iju+1
+                     indu(iju)=ij
+                  endif
+               enddo
+               niju=iju
+c              print*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               do iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  if(zu_m.gt.0.) then
+                     ijq=ij
+                     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)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   MODIFS SPECIFIQUES DU SCHEMA
+c   ajout de la maille non completement advectee
+             zsig=zu_m/masse(ijq,l)
+             if(zsig.le.zsigd(ijq,l)) then
+                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l)
+     s          -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l)))
+             else
+c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+c         goto 8888
+                zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l)
+                if(.not.(zz.gt.0..and.zz.le.0.5)) then
+                     WRITE(lunout,*)'probleme2 au point ij=',ij,
+     s               '  l=',l
+                     WRITE(lunout,*)'zz=',zz
+                     stop
+                endif
+                u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*(
+     s          0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l)
+     s        +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) )
+             endif
+                  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)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   ajout de la maille non completement advectee
+c 2eme MODIF SPECIFIQUE
+             zsig=-zu_m/masse(ij+1,l)
+             if(zsig.le.zsigg(ijq,l)) then
+                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l)
+     s          -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l)))
+             else
+c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+c           goto 9999
+                zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l)
+                if(.not.(zz.gt.0..and.zz.le.0.5)) then
+                     WRITE(lunout,*)'probleme22 au point ij=',ij
+     s               ,'  l=',l
+                     WRITE(lunout,*)'zz=',zz
+                     stop
+                endif
+                u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*(
+     s          0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l)
+     s          +(zsig-zsigg(ijq,l))*
+     s           (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) )
+             endif
+c   fin de la modif
+                  endif
+               enddo
+            endif
+         enddo
+      endif  ! n0.gt.0 
+
+c   bouclage en latitude
+      do l=1,llm
+        do ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        enddo
+      enddo
+
+c=================================================================
+c   CALCUL DE LA CONVERGENCE DES FLUX
+c=================================================================
+
+      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)+
+     &      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)
+         do ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         enddo
+      enddo
+
+      RETURN
+      END
+      SUBROUTINE advny(q,qs,qn,masse,v_m)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real masse(ip1jmp1,llm)
+      real v_m( ip1jm,llm )
+      real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real new_m,zdq,zz
+      real zsigs(ip1jmp1),zsign(ip1jmp1),zsig
+      real v_mq(ip1jm,llm)
+      real convpn,convps,convmpn,convmps,massen,masses
+      real zm,zq,zsigm,zsigp,zqm,zqp
+      real ssum
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+      do l=1,llm
+            do ij=1,ip1jmp1
+               zdq=qn(ij,l)-qs(ij,l)
+c              if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l,'  advnqx'
+c                 print*,qn(ij,l),q(ij,l),qs(ij,l)
+c                 qn(ij,l)=q(ij,l)
+c                 qs(ij,l)=q(ij,l)
+c              endif
+               if(abs(zdq).gt.prec) then
+                  zsign(ij)=(q(ij,l)-qs(ij,l))/zdq
+                  zsigs(ij)=1.-zsign(ij)
+c                 if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and.
+c    s               zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then
+c                    print*,'probleme au point ij=',ij,'  l=',l
+c                    print*,'sigs=',zsigs(ij),'  sign=',zsign(ij)
+c                    stop
+c                 endif
+               else
+                  zsign(ij)=0.5
+                  zsigs(ij)=0.5
+               endif
+            enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+       do ij=1,ip1jm
+          if (v_m(ij,l).ge.0.) then
+             zsigp=zsign(ij+iip1)
+             zsigm=zsigs(ij+iip1)
+             zqp=qn(ij+iip1,l)
+             zqm=qs(ij+iip1,l)
+             zm=masse(ij+iip1,l)
+             zq=q(ij+iip1,l)
+          else
+             zsigm=zsign(ij)
+             zsigp=zsigs(ij)
+             zqm=qn(ij,l)
+             zqp=qs(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          endif
+          zsig=abs(v_m(ij,l))/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (zsig.le.zsigp) then
+              v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+          else
+              zz=0.5*(zsig-zsigp)/zsigm
+              v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp 
+     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+          endif
+       enddo
+      enddo
+
+      do l=1,llm
+         do ij=iip2,ip1jm
+            new_m=masse(ij,l)
+     &      +v_m(ij,l)-v_m(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l))
+     &         /new_m
+            masse(ij,l)=new_m
+         enddo
+c.-. ancienne version
+         convpn=SSUM(iim,v_mq(1,l),1)
+         convmpn=ssum(iim,v_m(1,l),1)
+         massen=ssum(iim,masse(1,l),1)
+         new_m=massen+convmpn
+         q(1,l)=(q(1,l)*massen+convpn)/new_m
+         do ij = 1,iip1
+            q(ij,l)=q(1,l)
+            masse(ij,l)=new_m*aire(ij)/apoln
+         enddo
+
+         convps=-SSUM(iim,v_mq(ip1jm-iim,l),1)
+         convmps=-ssum(iim,v_m(ip1jm-iim,l),1)
+         masses=ssum(iim,masse(ip1jm+1,l),1)
+         new_m=masses+convmps
+         q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m
+         do ij = ip1jm+1,ip1jmp1
+            q(ij,l)=q(ip1jm+1,l)
+            masse(ij,l)=new_m*aire(ij)/apols
+         enddo
+      enddo
+
+      RETURN
+      END
+      SUBROUTINE advnz(q,qh,qb,masse,w_m)
+c
+c     Auteurs:   F.Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c     b designe le bas et h le haut
+c     il y a une correspondance entre le b en z et le d en x
+c    ********************************************************************
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real masse(ip1jmp1,llm)
+      real w_m( ip1jmp1,llm+1)
+      real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm)
+
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real new_m,zdq,zz
+      real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig
+      real w_mq(ip1jmp1,llm+1)
+      real zm,zq,zsigm,zsigp,zqm,zqp
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-13/
+#endif
+
+      do l=1,llm
+            do ij=1,ip1jmp1
+               zdq=qb(ij,l)-qh(ij,l)
+c              if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l
+c                 print*,qh(ij,l),q(ij,l),qb(ij,l)
+c                 qh(ij,l)=q(ij,l)
+c                 qb(ij,l)=q(ij,l)
+c              endif
+
+               if(abs(zdq).gt.prec) then
+                  zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq
+                  zsigh(ij,l)=1.-zsigb(ij,l)
+                  zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.)
+               else
+                  zsigb(ij,l)=0.5
+                  zsigh(ij,l)=0.5
+               endif
+            enddo
+       enddo
+
+c      print*,'ok1'
+c   calcul de la pente maximum dans la maille en valeur absolue
+       do l=2,llm
+       do ij=1,ip1jmp1
+          if (w_m(ij,l).ge.0.) then
+             zsigp=zsigb(ij,l)
+             zsigm=zsigh(ij,l)
+             zqp=qb(ij,l)
+             zqm=qh(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          else
+             zsigm=zsigb(ij,l-1)
+             zsigp=zsigh(ij,l-1)
+             zqm=qb(ij,l-1)
+             zqp=qh(ij,l-1)
+             zm=masse(ij,l-1)
+             zq=q(ij,l-1)
+          endif
+          zsig=abs(w_m(ij,l))/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (zsig.le.zsigp) then
+              w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+          else
+              zz=0.5*(zsig-zsigp)/zsigm
+              w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp
+     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+          endif
+      enddo
+      enddo
+
+       do ij=1,ip1jmp1
+          w_mq(ij,llm+1)=0.
+          w_mq(ij,1)=0.
+       enddo
+
+      do l=1,llm
+         do ij=1,ip1jmp1
+            new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l))
+     &         /new_m
+            masse(ij,l)=new_m
+         enddo
+      enddo
+c     print*,'ok3'
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advtrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advtrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advtrac.F	(revision 984)
@@ -0,0 +1,331 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE advtrac(pbaru,pbarv ,
+     *                   p,  masse,q,iapptrac,teta,
+     *                  flxw,
+     *                  pk)
+c     Auteur :  F. Hourdin
+c
+c     Modif. P. Le Van     (20/12/97)
+c            F. Codron     (10/99)
+c            D. Le Croller (07/2001)
+c            M.A Filiberti (04/2002)
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comdissip.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "advtrac.h"
+
+c-------------------------------------------------------------------
+c     Arguments
+c-------------------------------------------------------------------
+c     Ajout PPM
+c--------------------------------------------------------
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm)
+c--------------------------------------------------------
+      INTEGER iapptrac
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL q(ip1jmp1,llm,nqmx),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm)
+      REAL pk(ip1jmp1,llm)
+      REAL flxw(ip1jmp1,llm)
+
+c-------------------------------------------------------------
+c     Variables locales
+c-------------------------------------------------------------
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+      REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) 
+      REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu
+      real cpuadv(nqmx)
+      common/cpuadv/cpuadv
+
+      INTEGER iadvtr
+      INTEGER ij,l,iq,iiq
+      REAL zdpmin, zdpmax
+      EXTERNAL  minmax
+      SAVE iadvtr, massem, pbaruc, pbarvc
+      DATA iadvtr/0/
+c----------------------------------------------------------
+c     Rajouts pour PPM
+c----------------------------------------------------------
+      INTEGER indice,n
+      REAL dtbon ! Pas de temps adaptatif pour que CFL<1
+      REAL CFLmaxz,aaa,bbb ! CFL maximum
+      REAL psppm(iim,jjp1) ! pression  au sol
+      REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm)
+      REAL qppm(iim*jjp1,llm,nqmx)
+      REAL fluxwppm(iim,jjp1,llm)
+      REAL apppm(llmp1), bpppm(llmp1)
+      LOGICAL dum,fill
+      DATA fill/.true./
+      DATA dum/.true./
+
+
+      IF(iadvtr.EQ.0) THEN
+         CALL initial0(ijp1llm,pbaruc)
+         CALL initial0(ijmllm,pbarvc)
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+
+         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+ccc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+c
+      ENDIF
+
+      iadvtr   = iadvtr+1
+      iapptrac = iadvtr
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.iapp_tracvl ) THEN
+
+cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
+cc
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+      ! ... Flux de masse diaganostiques traceurs
+      flxw = wg / FLOAT(iapp_tracvl)
+
+c  test sur l'eventuelle creation de valeurs negatives de la masse
+         DO l=1,llm-1
+            DO ij = iip2+1,ip1jm
+              zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l)
+     s                  - pbarvg(ij-iip1,l) + pbarvg(ij,l)
+     s                  +       wg(ij,l+1)  - wg(ij,l)
+            ENDDO
+            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+            DO ij = iip2,ip1jm
+               zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+            ENDDO 
+
+
+            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+
+            IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+            PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin,
+     s        '   MAX:', zdpmax
+            ENDIF
+
+         ENDDO
+
+c-------------------------------------------------------------------
+c   Advection proprement dite (Modification Le Croller (07/2001)
+c-------------------------------------------------------------------
+
+c----------------------------------------------------
+c        Calcul des moyennes basées sur la masse
+c----------------------------------------------------
+          call massbar(massem,massebx,masseby)          
+
+c-----------------------------------------------------------
+c     Appel des sous programmes d'advection
+c-----------------------------------------------------------
+      do iq=1,nqmx
+c        call clock(t_initial)
+        if(iadv(iq) == 0) cycle 
+c   ----------------------------------------------------------------
+c   Schema de Van Leer I MUSCL
+c   ----------------------------------------------------------------
+        if(iadv(iq).eq.10) THEN
+            call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
+
+
+c   ----------------------------------------------------------------
+c   Schema "pseudo amont" + test sur humidite specifique
+C    pour la vapeur d'eau. F. Codron
+c   ----------------------------------------------------------------
+        else if(iadv(iq).eq.14) then
+c
+           CALL vlspltqs( q(1,1,1), 2., massem, wg ,
+     *                 pbarug,pbarvg,dtvr,p,pk,teta )
+c   ----------------------------------------------------------------
+c   Schema de Frederic Hourdin
+c   ----------------------------------------------------------------
+        else if(iadv(iq).eq.12) then
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+           do indice=1,n
+            call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+           end do
+        else if(iadv(iq).eq.13) then
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+          do indice=1,n
+            call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+          end do
+c   ----------------------------------------------------------------
+c   Schema de pente SLOPES
+c   ----------------------------------------------------------------
+        else if (iadv(iq).eq.20) then
+            call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+c   ----------------------------------------------------------------
+c   Schema de Prather
+c   ----------------------------------------------------------------
+        else if (iadv(iq).eq.30) then
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg,
+     s                     n,dtbon)
+
+c   ----------------------------------------------------------------
+c   Schemas PPM Lin et Rood
+c   ----------------------------------------------------------------
+         else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND.
+     s                     iadv(iq).LE.18)) then
+
+c        Test sur le flux horizontal
+c        Pas de temps adaptatif
+         call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+         if (n.GT.1) then
+         write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+         endif
+c        Test sur le flux vertical
+         CFLmaxz=0.
+         do l=2,llm
+           do ij=iip2,ip1jm
+            aaa=wg(ij,l)*dtvr/massem(ij,l)
+            CFLmaxz=max(CFLmaxz,aaa)
+            bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+            CFLmaxz=max(CFLmaxz,bbb)
+           enddo
+         enddo
+         if (CFLmaxz.GE.1) then
+            write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+         endif
+
+c-----------------------------------------------------------
+c        Ss-prg interface LMDZ.4->PPM3d
+c-----------------------------------------------------------
+
+          call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem,
+     s                 apppm,bpppm,massebx,masseby,pbarug,pbarvg,
+     s                 unatppm,vnatppm,psppm)
+
+          do indice=1,n
+c---------------------------------------------------------------------
+c                         VL (version PPM) horiz. et PPM vert.
+c---------------------------------------------------------------------
+                if (iadv(iq).eq.11) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+
+c----------------------------------------------------------------------
+c                           Monotonic PPM
+c----------------------------------------------------------------------
+               else if (iadv(iq).eq.16) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c                           Semi Monotonic PPM
+c---------------------------------------------------------------------
+               else if (iadv(iq).eq.17) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c                         Positive Definite PPM
+c---------------------------------------------------------------------
+                else if (iadv(iq).eq.18) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+                endif
+            enddo
+c-----------------------------------------------------------------
+c               Ss-prg interface PPM3d-LMDZ.4
+c-----------------------------------------------------------------
+                  call interpost(q(1,1,iq),qppm(1,1,iq))
+            endif
+c----------------------------------------------------------------------
+
+c-----------------------------------------------------------------
+c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
+c et Nord j=1
+c-----------------------------------------------------------------
+
+c                  call traceurpole(q(1,1,iq),massem)
+
+c calcul du temps cpu pour un schema donne
+
+c                  call clock(t_final)
+cym                  tps_cpu=t_final-t_initial
+cym                  cpuadv(iq)=cpuadv(iq)+tps_cpu
+
+       end DO
+
+
+c------------------------------------------------------------------
+c   on reinitialise a zero les flux de masse cumules
+c---------------------------------------------------
+          iadvtr=0
+
+       ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advtrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advtrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advtrac.h	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'advtrac.h'
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+
+      COMMON/advtr/iadv, hadv, vadv, tnom, tname, ttext, niadv,         &
+     &   nbtrac, nprath, mmt_adj, hadv_flg, vadv_flg, conv_flg,         &
+     &   pbl_flg, tracnam
+      INTEGER iadv(nqmx) ! indice schema de transport 
+      INTEGER hadv(nqmx) ! indice schema transport horizontal 
+      INTEGER vadv(nqmx) ! indice schema transport vertical 
+      INTEGER niadv(nqmx) ! equivalent dyn / physique
+      character (len=8) :: tnom(nqmx) ! nom court du traceur
+      character (len=10) :: tname(nqmx) ! nom du traceur pour restart
+      character (len=13) :: ttext(nqmx) ! nom long du traceur pour sorties
+
+
+      integer nbtrac
+      integer nprath
+      real    mmt_adj(iim+1,jjm+1,llm, 1) 
+      integer hadv_flg(nqmx)
+      integer vadv_flg(nqmx)
+      integer conv_flg(nqmx-2) 
+      integer pbl_flg(nqmx-2)
+      character (len=8) :: tracnam(nqmx-2) 
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advx.F	(revision 984)
@@ -0,0 +1,499 @@
+!
+! $Header$
+!
+      SUBROUTINE  advx(limit,dtx,pbaru,sm,s0,
+     $     sx,sy,sz,lati,latf)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (FOM) advection of tracer in X direction  C
+C                                                                C
+C  Source : Pascal Simon (Meteo,CNRM)                            C
+C  Adaptation : A.Armengaud (LGGE) juin 94                       C
+C                                                                C
+C  limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C
+C  sont des arguments d'entree pour le s-pg...                   C
+C                                                                C
+C  sm,s0,sx,sy,sz                                                C
+C  sont les arguments de sortie pour le s-pg                     C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+C  Arguments :
+C  -----------
+C  dtx : frequence fictive d'appel du transport 
+C  pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1
+
+       INTEGER ntra
+       PARAMETER (ntra = 1)
+
+C ATTENTION partout ou on trouve ntra, insertion de boucle
+C           possible dans l'avenir.
+
+      REAL dtx
+      REAL pbaru ( iip1,jjp1,llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     $    ,sy(iip1,jjp1,llm,ntra)
+      REAL sz(iip1,jjp1,llm,ntra)
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL UGRI(iip1,jjp1,llm)
+
+C  Rem : VGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en x uniquement )
+C
+C  Ti are the moments for the current latitude and level
+C
+      REAL TM(iim)
+      REAL T0(iim,ntra),TX(iim,ntra)
+      REAL TY(iim,ntra),TZ(iim,ntra)
+      REAL TEMPTM                ! just a temporary variable
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL FM(iim)
+      REAL F0(iim,ntra),FX(iim,ntra)
+      REAL FY(iim,ntra),FZ(iim,ntra)
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+C
+      REAL SMNEW(iim),UEXT(iim)
+C
+      REAL sqi,sqf
+
+      LOGICAL LIMIT
+      INTEGER NUM(jjp1),LONK,NUMK
+      INTEGER lon,lati,latf,niv
+      INTEGER i,i2,i3,j,jv,l,k,itrac 
+
+      lon = iim 
+      niv = llm 
+
+C *** Test de passage d'arguments ******
+
+
+C  -------------------------------------
+      DO 300 j = 1,jjp1 
+         NUM(j) = 1
+  300 CONTINUE
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+cIM 240305            sqi = sqi + S0(i,j,l,9)
+               sqi = sqi + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------'
+      PRINT*,'sqi=',sqi
+
+
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  ---------------------------------------------------------
+C  Conversion des flux de masses en kg/s
+C  pbaru est en N/s d'ou :
+C  ugri est en kg/s
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjm+1
+            DO 500 i = 1,iip1  
+C            ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )
+             ugri (i,j,llm+1-l) = pbaru (i,j,l)
+  500 CONTINUE
+
+
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+  
+C  start here          
+C
+C  boucle principale sur les niveaux et les latitudes
+C
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+C
+C  modifications for extended polar zones
+C
+      NUMK=NUM(K)
+      LONK=LON/NUMK
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0(I,JV)=0.
+         TX(I,JV)=0.
+         TY(I,JV)=0.
+         TZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TM(I)=TM(I)+SM(I3,K,L)
+            ALF(I)=SM(I3,K,L)/TM(I)
+            ALF1(I)=1.-ALF(I)
+ 113     CONTINUE
+C
+         DO  JV=1,NTRA
+         DO  I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)
+     $          *S0(I3,K,L,JV)
+            T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+            TX(I,JV)=ALF(I)  *sx(I3,K,L,JV)+
+     $       ALF1(I)*TX(I,JV) +3.*TEMPTM
+            TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV)
+            TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV)
+         ENDDO 
+         ENDDO
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 I=1,LON
+         T0(I,JV)=S0(I,K,L,JV)
+         TX(I,JV)=sx(I,K,L,JV)
+         TY(I,JV)=sy(I,K,L,JV)
+         TZ(I,JV)=sz(I,K,L,JV)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 13
+C
+      DO 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))
+ 120  CONTINUE
+ 12   CONTINUE
+C
+ 13   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from IP to I if U(I).lt.0
+C
+      DO 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+        FM(I)=-UEXT(I)*DTX
+        ALF(I)=FM(I)/TM(1)
+        TM(1)=TM(1)-FM(I)
+      ENDIF
+C
+C  flux from I to IP if U(I).gt.0
+C
+      DO 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) )
+           FX(I,JV)=ALFQ(I)*TX(I+1,JV)
+           FY(I,JV)=ALF (I)*TY(I+1,JV)
+           FZ(I,JV)=ALF (I)*TZ(I+1,JV)
+C
+           T0(I+1,JV)=T0(I+1,JV)-F0(I,JV)
+           TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV)
+           TY(I+1,JV)=TY(I+1,JV)-FY(I,JV)
+           TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV)
+C
+         ENDIF
+C
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 JV=1,NTRA
+C
+           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) )
+           FX (I,JV)=ALFQ(I)*TX(1,JV)
+           FY (I,JV)=ALF (I)*TY(1,JV)
+           FZ (I,JV)=ALF (I)*TZ(1,JV)
+C
+           T0(1,JV)=T0(1,JV)-F0(I,JV)
+           TX(1,JV)=ALF1Q(I)*TX(1,JV)
+           TY(1,JV)=TY(1,JV)-FY(I,JV)
+           TZ(1,JV)=TZ(1,JV)-FZ(I,JV)
+C
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) )
+           FX(I,JV)=ALFQ(I)*TX(I,JV)
+           FY(I,JV)=ALF (I)*TY(I,JV)
+           FZ(I,JV)=ALF (I)*TZ(I,JV)
+C
+           T0(I,JV)=T0(I,JV)-F0(I,JV)
+           TX(I,JV)=ALF1Q(I)*TX(I,JV)
+           TY(I,JV)=TY(I,JV)-FY(I,JV)
+           TZ(I,JV)=TZ(I,JV)-FZ(I,JV)
+C
+         ENDIF
+C
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+           T0(I,JV)=T0(I,JV)+F0(I,JV)
+           TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+           TY(I,JV)=TY(I,JV)+FY(I,JV)
+           TZ(I,JV)=TZ(I,JV)+FZ(I,JV)
+C
+         ENDIF
+C
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+           T0(I+1,JV)=T0(I+1,JV)+F0(I,JV)
+           TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM
+           TY(I+1,JV)=TY(I+1,JV)+FY(I,JV)
+           TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV)
+C
+         ENDIF
+C
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 JV=1,NTRA
+           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+           T0(1,JV)=T0(1,JV)+F0(I,JV)
+           TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+           TY(1,JV)=TY(1,JV)+FY(I,JV)
+           TZ(1,JV)=TZ(1,JV)+FZ(I,JV)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 180 I2=1,NUMK
+C
+         DO 180 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            SM(I3,K,L)=SMNEW(I3)
+            ALF(I)=SMNEW(I3)/TM(I)
+            TM(I)=TM(I)-SMNEW(I3)
+C
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1(I)=1.-ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 180     CONTINUE
+C
+         DO  JV=1,NTRA
+         DO  I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            S0(I3,K,L,JV)=ALF (I)
+     $       * (T0(I,JV)-ALF1(I)*TX(I,JV))
+            sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV)
+            sy(I3,K,L,JV)=ALF (I)*TY(I,JV)
+            sz(I3,K,L,JV)=ALF (I)*TZ(I,JV)
+C
+C   reajusts moments remaining in the box
+C
+            T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+            TX(I,JV)=ALF1Q(I)*TX(I,JV)
+            TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV)
+            TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV)
+          ENDDO
+          ENDDO
+C
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 I=1,LON
+         S0(I,K,L,JV)=T0(I,JV)
+         sx(I,K,L,JV)=TX(I,JV)
+         sy(I,K,L,JV)=TY(I,JV)
+         sz(I,K,L,JV)=TZ(I,JV)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+c OK
+c      DO 9998 l = 1, llm
+c      DO 9998 j = 1, jjp1
+c      DO 9998 i = 1, iip1
+c         IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
+c            PRINT*, '-------------------'
+c            PRINT*, 'En fin de ADVX'
+c            PRINT*,'SM(',i,j,l,')=',SM(i,j,l)
+c            PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c            print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c            print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c            print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1'
+cc            STOP
+c         ENDIF
+c 9998 CONTINUE
+c
+C ---------- bouclage cyclique 
+      DO itrac=1,ntra
+      DO l = 1,llm
+        DO j = lati,latf
+           SM(iip1,j,l) = SM(1,j,l)
+           S0(iip1,j,l,itrac) = S0(1,j,l,itrac)
+           sx(iip1,j,l,itrac) = sx(1,j,l,itrac)
+           sy(iip1,j,l,itrac) = sy(1,j,l,itrac)
+           sz(iip1,j,l,itrac) = sz(1,j,l,itrac)
+        END DO
+      END DO
+      ENDDO 
+
+c ----------- qqtite totale de traceur dans tte l'atmosphere
+      DO l = 1, llm
+        DO j = 1, jjp1
+          DO i = 1, iim
+cIM 240405          sqf = sqf + S0(i,j,l,9)
+             sqf = sqf + S0(i,j,l,ntra)
+          END DO  
+        END DO
+      END DO
+c
+      PRINT*,'------ DIAG DANS ADVX - SORTIE -----'
+      PRINT*,'sqf=',sqf
+c-------------
+
+      RETURN
+      END
+C_________________________________________________________________
+C_________________________________________________________________
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advxp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advxp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advxp.F	(revision 984)
@@ -0,0 +1,650 @@
+!
+! $Header$
+!
+       SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ
+     .                ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
+       IMPLICIT NONE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in X direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+       INTEGER ntra
+c      PARAMETER (ntra = 1)
+C
+C  definition de la grille du modele
+C
+      REAL dtx
+      REAL pbaru ( iip1,jjp1,llm )
+C
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C           Sij 2nd  order moment in i and j directions
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+      REAL SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+
+C  Local :
+C  -------
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+       REAL UGRI(iip1,jjp1,llm)
+
+C  Rem : VGRI et WGRI ne sont pas utilises dans
+C  cette subroutine ( advection en x uniquement )
+C
+C
+C  Tij are the moments for the current latitude and level
+C
+      REAL TM (iim)
+      REAL T0 (iim,NTRA),TX (iim,NTRA)
+      REAL TY (iim,NTRA),TZ (iim,NTRA)
+      REAL TXX(iim,NTRA),TXY(iim,NTRA)
+      REAL TXZ(iim,NTRA),TYY(iim,NTRA)
+      REAL TYZ(iim,NTRA),TZZ(iim,NTRA)
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL FM (iim)
+      REAL F0 (iim,NTRA),FX (iim,NTRA)
+      REAL FY (iim,NTRA),FZ (iim,NTRA)
+      REAL FXX(iim,NTRA),FXY(iim,NTRA)
+      REAL FXZ(iim,NTRA),FYY(iim,NTRA)
+      REAL FYZ(iim,NTRA),FZZ(iim,NTRA)
+C
+C  work arrays
+C
+      REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+      REAL ALF2(iim),ALF3(iim),ALF4(iim)
+C
+      REAL SMNEW(iim),UEXT(iim)
+      REAL sqi,sqf
+      REAL TEMPTM
+      REAL SLPMAX
+      REAL S1MAX,S1NEW,S2NEW
+
+      LOGICAL LIMIT
+      INTEGER NUM(jjp1),LONK,NUMK
+      INTEGER lon,lati,latf,niv
+      INTEGER i,i2,i3,j,jv,l,k,iter
+
+      lon = iim
+      lati=2
+      latf = jjm
+      niv = llm
+
+C *** Test de passage d'arguments ******
+
+c      DO 399 l = 1, llm
+c       DO 399 j = 1, jjp1
+c        DO 399 i = 1, iip1
+c         IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+c         PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c	     print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+c         print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+c         print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+c         PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
+cc            STOP
+c         ENDIF
+c  399 CONTINUE
+
+C *** Test : diagnostique de la qtite totale de traceur
+C            dans l'atmosphere avant l'advection
+c
+      sqi =0.
+      sqf =0.
+c
+      DO l = 1, llm
+      DO j = 1, jjp1
+      DO i = 1, iim
+	 sqi = sqi + S0(i,j,l,ntra)
+      END DO
+      END DO
+      END DO
+      PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
+      PRINT*,'sqi=',sqi
+c test
+c  -------------------------------------
+        DO 300 j =1,jjp1
+         NUM(j) =1 
+ 300  CONTINUE
+c       DO l=1,llm
+c      NUM(2,l)=6
+c      NUM(3,l)=6
+c      NUM(jjm-1,l)=6  
+c      NUM(jjm,l)=6
+c      ENDDO
+c        DO j=2,6
+c       NUM(j)=12
+c       ENDDO
+c       DO j=jjm-5,jjm-1 
+c       NUM(j)=12
+c       ENDDO
+
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  ---------------------------------------------------------
+C  Conversion des flux de masses en kg/s
+C  pbaru est en N/s d'ou :
+C  ugri est en kg/s
+
+       DO 500 l = 1,llm
+       DO 500 j = 1,jjp1
+       DO 500 i = 1,iip1
+       ugri (i,j,llm+1-l) =pbaru (i,j,l) 
+ 500   CONTINUE
+
+C  ---------------------------------------------------------
+C  start here
+C
+C  boucle principale sur les niveaux et les latitudes
+C     
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+C
+C  modifications for extended polar zones
+C
+      NUMK=NUM(K)
+      LONK=LON/NUMK
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0 (I,JV)=0.
+         TX (I,JV)=0.
+         TY (I,JV)=0.
+         TZ (I,JV)=0.
+         TXX(I,JV)=0.
+         TXY(I,JV)=0.
+         TXZ(I,JV)=0.
+         TYY(I,JV)=0.
+         TYZ(I,JV)=0.
+         TZZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TM(I)=TM(I)+SM(I3,K,L)
+            ALF(I)=SM(I3,K,L)/TM(I)
+            ALF1(I)=1.-ALF(I)
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+            ALF2(I)=ALF1(I)-ALF(I)
+            ALF3(I)=ALF(I)*ALF1(I)
+ 113     CONTINUE
+C
+         DO 114 JV=1,NTRA
+         DO 1140 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
+            T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+            TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV)
+     +        +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+            TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+            TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV)
+     +           +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
+            TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV)
+     +           +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
+            TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
+            TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
+            TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
+            TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
+            TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
+ 1140    CONTINUE
+ 114     CONTINUE
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 I=1,LON
+         T0 (I,JV)=S0 (I,K,L,JV)
+         TX (I,JV)=SSX (I,K,L,JV)
+         TY (I,JV)=SY (I,K,L,JV)
+         TZ (I,JV)=SZ (I,K,L,JV)
+         TXX(I,JV)=SSXX(I,K,L,JV)
+         TXY(I,JV)=SSXY(I,K,L,JV)
+         TXZ(I,JV)=SSXZ(I,K,L,JV)
+         TYY(I,JV)=SYY(I,K,L,JV)
+         TYZ(I,JV)=SYZ(I,K,L,JV)
+         TZZ(I,JV)=SZZ(I,K,L,JV)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 13
+C
+      DO 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        IF(T0(I,JV).GT.0.) THEN
+          SLPMAX=T0(I,JV)
+          S1MAX=1.5*SLPMAX
+          S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
+          S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                 AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
+          TX (I,JV)=S1NEW
+          TXX(I,JV)=S2NEW
+          TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
+          TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
+        ELSE
+          TX (I,JV)=0.
+          TXX(I,JV)=0.
+          TXY(I,JV)=0.
+          TXZ(I,JV)=0.
+        ENDIF
+ 120  CONTINUE
+ 12   CONTINUE
+C
+ 13   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from IP to I if U(I).lt.0
+C
+      DO 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+        FM(I)=-UEXT(I)*DTX
+        ALF(I)=FM(I)/TM(1)
+        TM(1)=TM(1)-FM(I)
+      ENDIF
+C
+C  flux from I to IP if U(I).gt.0
+C
+      DO 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF1(I)-ALF(I)
+         ALF3(I)=ALF(I)*ALFQ(I)
+         ALF4(I)=ALF1(I)*ALF1Q(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
+     +             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
+           FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
+           FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
+           FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
+           FYY(I,JV)=ALF (I)*TYY(I+1,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
+C
+           T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
+           TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
+           TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
+           TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
+           TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
+           TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
+           TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
+           TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
+           TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
+           TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
+C
+         ENDIF
+C
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 JV=1,NTRA
+C
+           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
+     +             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
+           FXX(I,JV)=ALF3(I)*TXX(1,JV)
+           FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
+           FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(1,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
+           FYY(I,JV)=ALF (I)*TYY(1,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(1,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(1,JV)
+C
+           T0 (1,JV)=T0(1,JV)-F0(I,JV)
+           TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
+           TXX(1,JV)=ALF4(I)*TXX(1,JV)
+           TY (1,JV)=TY (1,JV)-FY (I,JV)
+           TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
+           TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
+           TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
+           TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
+           TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
+           TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
+C
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
+     +             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
+           FXX(I,JV)=ALF3(I)*TXX(I,JV)
+           FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
+           FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(I,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
+           FYY(I,JV)=ALF (I)*TYY(I,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(I,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(I,JV)
+C
+           T0 (I,JV)=T0(I,JV)-F0(I,JV)
+           TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
+           TXX(I,JV)=ALF4(I)*TXX(I,JV)
+           TY (I,JV)=TY (I,JV)-FY (I,JV)
+           TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
+           TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
+           TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
+           TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
+           TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+           TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+C
+         ENDIF
+C
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF1(I)-ALF(I)
+         ALF3(I)=ALF(I)*ALF1(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+           T0 (I,JV)=T0(I,JV)+F0(I,JV)
+           TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV)
+     +          +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+           TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
+           TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV)
+     +          +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
+           TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV)
+     +          +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
+           TY (I,JV)=TY (I,JV)+FY (I,JV)
+           TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
+           TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
+           TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
+           TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
+C
+         ENDIF
+C
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+           T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
+           TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV)
+     +           +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+           TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
+           TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV)
+     +            +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
+           TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV)
+     +            +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
+           TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
+           TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
+           TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
+           TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
+           TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
+C
+         ENDIF
+C
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 JV=1,NTRA
+           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+           T0 (1,JV)=T0(1,JV)+F0(I,JV)
+           TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV)
+     +         +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+           TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+           TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV)
+     +          +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
+           TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV)
+     +          +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
+           TY (1,JV)=TY (1,JV)+FY (I,JV)
+           TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
+           TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
+           TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
+           TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 18 I2=1,NUMK
+C
+         DO 180 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            SM(I3,K,L)=SMNEW(I3)
+            ALF(I)=SMNEW(I3)/TM(I)
+            TM(I)=TM(I)-SMNEW(I3)
+C
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1(I)=1.-ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+            ALF2(I)=ALF1(I)-ALF(I)
+            ALF3(I)=ALF(I)*ALFQ(I)
+            ALF4(I)=ALF1(I)*ALF1Q(I)
+C
+ 180     CONTINUE
+C
+         DO 181 JV=1,NTRA
+         DO 181 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
+     +              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
+            SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
+            SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
+            SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
+            SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
+            SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
+            SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
+            SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
+            SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
+            SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
+C
+C   reajusts moments remaining in the box
+C
+            T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+            TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
+            TXX(I,JV)=ALF4 (I)*TXX(I,JV)
+            TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
+            TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
+            TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
+            TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
+            TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
+            TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+            TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+C
+ 181     CONTINUE
+C
+ 18   CONTINUE
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 I=1,LON
+         S0 (I,K,L,JV)=T0 (I,JV)
+         SSX (I,K,L,JV)=TX (I,JV)
+         SY (I,K,L,JV)=TY (I,JV)
+         SZ (I,K,L,JV)=TZ (I,JV)
+         SSXX(I,K,L,JV)=TXX(I,JV)
+         SSXY(I,K,L,JV)=TXY(I,JV)
+         SSXZ(I,K,L,JV)=TXZ(I,JV)
+         SYY(I,K,L,JV)=TYY(I,JV)
+         SYZ(I,K,L,JV)=TYZ(I,JV)
+         SZZ(I,K,L,JV)=TZZ(I,JV)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+
+c      DO 9999 l = 1, llm
+c      DO 9999 j = 1, jjp1
+c      DO 9999 i = 1, iip1
+c	   IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
+c           PRINT*, '-------------------'
+c	        PRINT*, 'En fin de ADVXP'
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c	        print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+c           print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+c       	print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
+c            STOP
+c           ENDIF
+c 9999 CONTINUE
+c ---------- bouclage cyclique
+
+      DO l = 1,llm
+      DO j = 1,jjp1
+         SM(iip1,j,l) = SM(1,j,l)
+         S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+     	 SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+    	 SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+    	 SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+      END DO
+      END DO
+
+C ----------- qqtite totale de traceur dans tte l'atmosphere
+      DO l = 1, llm
+      DO j = 1, jjp1
+      DO i = 1, iim
+        sqf = sqf + S0(i,j,l,ntra)
+      END DO
+      END DO
+      END DO
+
+      PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
+      PRINT*,'sqf=',sqf
+c-------------------------------------------------------------
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advy.F	(revision 984)
@@ -0,0 +1,422 @@
+!
+! $Header$
+!
+      SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (SOM) advection of tracer in Y direction  C
+C                                                                C
+C  Source : Pascal Simon ( Meteo, CNRM )			 C
+C  Adaptation : A.A. (LGGE) 					 C
+C  Derniere Modif : 15/12/94 LAST
+C								 C
+C  sont les arguments d'entree pour le s-pg			 C
+C								 C
+C  argument de sortie du s-pg					 C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation 
+C
+C  parametres principaux du modele
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+ 
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,kp,l
+      INTEGER ntra
+      PARAMETER (ntra = 1)
+
+      REAL dty
+      REAL pbarv ( iip1,jjm, llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     +    ,sy(iip1,jjp1,llm,ntra)
+     +    ,sz(iip1,jjp1,llm,ntra)
+
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL VGRI(iip1,0:jjp1,llm)
+
+C  Rem : UGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en y uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+      REAL FZ(iim,jjm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+      REAL TEMPTM          ! Just temporal variable
+c
+C  Special pour poles 
+c
+      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
+      REAL sns0(ntra),snsz(ntra),snsm
+      REAL s1v(llm),slatv(llm)
+      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+      REAL cx1(llm,ntra), cxLAT(llm,ntra)
+      REAL cy1(llm,ntra), cyLAT(llm,ntra)
+      REAL z1(iim), zcos(iim), zsin(iim)
+      real smpn,smps,s0pn,s0ps
+      REAL SSUM
+      EXTERNAL SSUM
+C
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv=llm
+
+C
+C  the moments Fi are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+
+      DO l = 1,llm
+         DO j = 1,jjm
+            DO i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)  
+            enddo
+         enddo
+         do i=1,iip1
+             vgri(i,0,l) = 0.
+             vgri(i,jjp1,l) = 0.
+         enddo
+      enddo
+
+      DO 1 L=1,NIV
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 11
+C
+      DO 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
+     +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+           FM(I,0)=-VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+           SM(I,1,L)=SM(I,1,L)-FM(I,0)
+           SM0=SM0+FM(I,0)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+C
+ 21   CONTINUE
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+C
+           F0(I,0,JV)=ALF(I,0)*
+     +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
+C
+           S00(JV)=S00(JV)+F0(I,0,JV)
+           S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+           sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
+           sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
+           sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
+C
+         ENDIF
+C
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+           SM(I,1,L)=SM(I,1,L)+FM(I,0)
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+         ENDIF
+C
+         ALF1(I,0)=1.-ALF(I,0)
+C
+ 25   CONTINUE
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+C
+         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+         S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+         sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
+C
+         ENDIF
+C
+ 260  CONTINUE
+ 26   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+         ELSE
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+C
+ 300  CONTINUE
+ 30   CONTINUE
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+           F0(I,K,JV)=ALF (I,K)*
+     +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
+           FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
+           FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
+           FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
+C
+           S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+           sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
+           sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
+           sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
+C
+         ELSE
+C
+           F0(I,K,JV)=ALF (I,K)*
+     +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+           FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
+           FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
+           FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
+C
+           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
+           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
+           sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
+C
+         ENDIF
+C
+ 310  CONTINUE
+ 31   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ELSE
+           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+         ENDIF
+C
+         ALF1(I,K)=1.-ALF(I,K)
+C
+ 320  CONTINUE
+ 32   CONTINUE
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV)
+     +               +3.*TEMPTM
+         sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
+         sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
+C
+         ELSE
+C
+         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+         S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+         sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV)
+     +                +3.*TEMPTM
+         sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
+         sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
+C
+         ENDIF
+C
+ 330  CONTINUE
+ 33   CONTINUE
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+           SM0=SM0+FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+C
+ 41   CONTINUE
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           F0 (I,K,JV)=ALF(I,K)*
+     +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+           S00(JV)=S00(JV)+F0(I,K,JV)
+C
+           S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+           sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
+           sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
+         ENDIF
+C
+ 420  CONTINUE
+ 42   CONTINUE
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ENDIF
+C
+         ALF1(I,K)=1.-ALF(I,K)
+C
+ 45   CONTINUE
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
+C
+         ENDIF
+C
+ 460  CONTINUE
+ 46   CONTINUE
+C
+ 1    CONTINUE
+C
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advyp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advyp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advyp.F	(revision 984)
@@ -0,0 +1,653 @@
+!
+! $Header$
+!
+      SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
+     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+      IMPLICIT NONE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in Y direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  Source : Pascal Simon ( Meteo, CNRM )			 C
+C  Adaptation : A.A. (LGGE) 					 C
+C  Derniere Modif : 19/10/95 LAST
+C								 C
+C  sont les arguments d'entree pour le s-pg			 C
+C								 C
+C  argument de sortie du s-pg					 C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation 
+C
+C  parametres principaux du modele
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+ 
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,kp,l
+      INTEGER ntra
+C      PARAMETER (ntra = 1)
+
+      REAL dty
+      REAL pbarv ( iip1,jjm, llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+     +    ,SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+C
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL VGRI(iip1,0:jjp1,llm)
+
+C  Rem : UGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en y uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+C  the moments Fij are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+C
+      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+      REAL FZ(iim,jjm,ntra)
+      REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
+      REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
+      REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+      REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
+      REAL ALF4(iim,0:jjp1)
+      REAL TEMPTM          ! Just temporal variable
+      REAL SLPMAX,S1MAX,S1NEW,S2NEW
+c
+C  Special pour poles 
+c
+      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
+      REAL sns0(ntra),snsz(ntra),snsm
+      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+      REAL cx1(llm,ntra), cxLAT(llm,ntra)
+      REAL cy1(llm,ntra), cyLAT(llm,ntra)
+      REAL z1(iim), zcos(iim), zsin(iim)
+      REAL SSUM
+      EXTERNAL SSUM
+C
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv = llm         !       tab. S et VGRI 
+                    
+c-----------------------------------------------------------------
+C initialisations
+
+      sbms = 0.
+      sfms = 0.
+      sfzs = 0.
+      sbmn = 0.
+      sfmn = 0.
+      sfzn = 0.
+
+c-----------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+c 
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqi = sqi + S0(i,j,l,ntra)
+           END DO
+         END DO
+      END DO
+      PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
+      PRINT*,'sqi=',sqi
+
+c-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion des flux de masses en kg
+C-AA 20/10/94  le signe -1 est necessaire car indexation opposee
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjm
+            DO 500 i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
+  500 CONTINUE
+
+CAA Initialisation de flux fictifs aux bords sup. des boites pol.
+
+      DO l = 1,llm
+         DO i = 1,iip1  
+             vgri(i,0,l) = 0.
+             vgri(i,jjp1,l) = 0.
+         ENDDO
+      ENDDO
+c
+c----------------- START HERE -----------------------
+C  boucle sur les niveaux
+C
+      DO 1 L=1,NIV
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 11
+C
+      DO 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         IF(S0(I,K,L,JV).GT.0.) THEN
+           SLPMAX=AMAX1(S0(I,K,L,JV),0.)
+           S1MAX=1.5*SLPMAX
+           S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
+           S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                  AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
+           SY (I,K,L,JV)=S1NEW
+           SYY(I,K,L,JV)=S2NEW
+       SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
+       SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+         ELSE
+           SY (I,K,L,JV)=0.
+           SYY(I,K,L,JV)=0.
+           SSXY(I,K,L,JV)=0.
+           SYZ(I,K,L,JV)=0.
+         ENDIF
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+           FM(I,0)=-VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+           SM(I,1,L)=SM(I,1,L)-FM(I,0)
+           SM0=SM0+FM(I,0)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+         ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
+         ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
+C
+ 21   CONTINUE
+c     print*,'ADVYP 21'
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+C
+           F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
+     +        ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
+C
+           S00(JV)=S00(JV)+F0(I,0,JV)
+           S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+           SY (I,1,L,JV)=ALF1Q(I,0)*
+     +            (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
+           SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
+           SSX (I,1,L,JV)=ALF1 (I,0)*
+     +            (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
+           SZ (I,1,L,JV)=ALF1 (I,0)*
+     +            (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
+           SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
+           SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
+           SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
+           SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
+           SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
+C
+         ENDIF
+C
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+c     print*,'av ADVYP 25'
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+           SM(I,1,L)=SM(I,1,L)+FM(I,0)
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+         ALF3(I,0)=ALF1(I,0)*ALF(I,0)
+C
+ 25   CONTINUE
+c     print*,'av ADVYP 25'
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+C
+         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+         S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+         SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
+     +        +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
+         SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
+      SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
+      SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
+C
+         ENDIF
+C
+ 260  CONTINUE
+ 26   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+c     print*,'av ADVYP 30'
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+         ELSE
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+C
+ 300  CONTINUE
+ 30   CONTINUE
+c     print*,'ap ADVYP 30'
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+           F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
+     +        ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
+           FY (I,K,JV)=ALFQ(I,K)*
+     +                 (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
+           FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
+           FX (I,K,JV)=ALF (I,K)*
+     +                 (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
+           FZ (I,K,JV)=ALF (I,K)*
+     +                 (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
+           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
+           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
+           FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
+           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
+           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
+C
+           S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+           SY (I,KP,L,JV)=ALF1Q(I,K)*
+     +                 (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
+           SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
+           SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
+           SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
+           SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
+           SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
+           SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
+           SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
+           SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
+C
+         ELSE
+C
+           F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
+     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+           FY (I,K,JV)=ALFQ(I,K)*
+     +                 (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
+           FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
+      FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
+      FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
+           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
+           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
+           FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
+           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
+           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           SY (I,K,L,JV)=ALF1Q(I,K)*
+     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+           SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
+           SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
+           SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
+           SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
+           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+C
+         ENDIF
+C
+ 310  CONTINUE
+ 31   CONTINUE
+c     print*,'ap ADVYP 31'
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ELSE
+           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+C
+ 320  CONTINUE
+ 32   CONTINUE
+c     print*,'ap ADVYP 32'
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+       SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV)
+     +  +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
+         SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV)
+     +            +3.*TEMPTM
+       SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV)
+     +         +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
+       SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV)
+     +         +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
+         SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
+         SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
+         SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
+         SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
+         SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
+C
+         ELSE
+C
+         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+         S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+       SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV)
+     +  +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
+         SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV)
+     +                 +3.*TEMPTM
+       SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV)
+     +             +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
+         SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV)
+     +             +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
+         SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
+         SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
+         SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
+         SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
+         SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
+C
+         ENDIF
+C
+ 330  CONTINUE
+ 33   CONTINUE
+c     print*,'ap ADVYP 33'
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+           SM0=SM0+FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+C
+ 41   CONTINUE
+c     print*,'ap ADVYP 41'
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
+     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+           S00(JV)=S00(JV)+F0(I,K,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           SY (I,K,L,JV)=ALF1Q(I,K)*
+     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+           SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
+      SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
+      SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
+           SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
+           SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
+           SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
+           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+         ENDIF
+C
+ 420  CONTINUE
+ 42   CONTINUE
+c     print*,'ap ADVYP 42'
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+c     print*,'ap ADVYP 43'
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+C
+ 45   CONTINUE
+c     print*,'ap ADVYP 45'
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
+     +           +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
+         SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
+      SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
+      SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
+C
+         ENDIF
+C
+ 460  CONTINUE
+ 46   CONTINUE
+c     print*,'ap ADVYP 46'
+C
+ 1    CONTINUE
+
+c--------------------------------------------------
+C     bouclage cyclique horizontal .
+     
+      DO l = 1,llm
+         DO jv = 1,ntra
+            DO j = 1,jjp1
+               SM(iip1,j,l) = SM(1,j,l)
+               S0(iip1,j,l,jv) = S0(1,j,l,jv)
+               SSX(iip1,j,l,jv) = SSX(1,j,l,jv)   
+               SY(iip1,j,l,jv) = SY(1,j,l,jv)
+               SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
+            END DO
+         END DO
+      END DO
+
+c -------------------------------------------------------------------
+C *** Test  negativite:
+
+c      DO jv = 1,ntra
+c       DO l = 1,llm
+c         DO j = 1,jjp1
+c           DO i = 1,iip1
+c              IF (s0( i,j,l,jv ).lt.0.) THEN
+c                 PRINT*, '------ S0 < 0 en FIN ADVYP ---'
+c                 PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
+cc                 STOP
+c              ENDIF
+c           ENDDO
+c         ENDDO
+c       ENDDO
+c      ENDDO
+ 
+   
+c -------------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+ 
+       DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqf = sqf + S0(i,j,l,ntra)
+           END DO
+         END DO
+       END DO
+      PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
+      PRINT*,'sqf=',sqf
+c     print*,'ap ADVYP fin'
+
+c-----------------------------------------------------------------
+C
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advz.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advz.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advz.F	(revision 984)
@@ -0,0 +1,322 @@
+!
+! $Header$
+!
+      SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (FOM) advection of tracer in Z direction  C
+C                                                                C
+C  Source : Pascal Simon (Meteo,CNRM)                            C
+C  Adaptation : A.Armengaud (LGGE) juin 94                       C
+C                                                                C
+C                                                                C
+C  sont des arguments d'entree pour le s-pg...                   C
+C                                                                C
+C  dq est l'argument de sortie pour le s-pg                      C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+C    #include "traceur.h"
+
+C  Arguments :
+C  -----------
+C  dtz : frequence fictive d'appel du transport 
+C  w : flux de masse en z en Pa.m2.s-1
+
+      INTEGER ntra
+      PARAMETER (ntra = 1)
+
+      REAL dtz
+      REAL w ( iip1,jjp1,llm )
+    
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     +    ,sy(iip1,jjp1,llm,ntra)
+     +    ,sz(iip1,jjp1,llm,ntra)
+
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL WGRI(iip1,jjp1,0:llm)
+
+C
+C  the moments F are used as temporary  storage for 
+C  portions of grid boxes in transit at the current latitude
+C
+      REAL FM(iim,llm)
+      REAL F0(iim,llm,ntra),FX(iim,llm,ntra)
+      REAL FY(iim,llm,ntra),FZ(iim,llm,ntra)
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+      REAL TEMPTM            ! Just temporal variable
+      REAL sqi,sqf
+C
+      LOGICAL LIMIT
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,l,lp
+
+      lon = iim
+      lat = jjp1
+      niv = llm 
+
+C *** Test de passage d'arguments ******
+ 
+c     DO 399 l = 1, llm
+c     DO 399 j = 1, jjp1
+c     DO 399 i = 1, iip1
+c        IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c           print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c           print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c           print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c           PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
+c            STOP
+c        ENDIF
+  399 CONTINUE
+
+C-----------------------------------------------------------------
+C *** Test : diag de la qqtite totale de traceur 
+C            dans l'atmosphere avant l'advection en z
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+cIM 240305            sqi = sqi + S0(i,j,l,9)
+               sqi = sqi + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
+      PRINT*,'sqi=',sqi
+
+C-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion du flux de masse en kg.s-1
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+c            wgri (i,j,llm+1-l) =  w (i,j,l) / g 
+               wgri (i,j,llm+1-l) =  w (i,j,l) 
+c             wgri (i,j,0) = 0.                ! a detruire ult.
+c             wgri (i,j,l) = 0.1               !    w (i,j,l) 
+c             wgri (i,j,llm) = 0.              ! a detruire ult.
+  500 CONTINUE
+         DO  j = 1,jjp1
+            DO i = 1,iip1  
+               wgri(i,j,0)=0.
+            enddo
+         enddo
+
+C-----------------------------------------------------------------
+  
+C  start here          
+C  boucle sur les latitudes
+C
+      DO 1 K=1,LAT
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 101
+C
+      DO 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
+     +                              ABS(sz(I,K,L,JV))),sz(I,K,L,JV))
+ 100     CONTINUE
+ 10   CONTINUE
+C
+ 101  CONTINUE
+C
+C  boucle sur les niveaux intercouches de 1 a NIV-1
+C   (flux nul au sommet L=0 et a la base L=NIV)
+C
+C  calculate flux and moments between adjacent boxes
+C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+      DO 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           FM(I,L)=-WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+         ELSE
+           FM(I,L)=WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,L)
+         ENDIF
+C
+         ALFQ (I)=ALF(I)*ALF(I)
+         ALF1 (I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) )
+           FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
+           FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
+           FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
+C
+           S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
+           sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
+           sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
+           sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
+C
+         ELSE
+C
+           F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) )
+           FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
+           FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
+           FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
+C
+           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
+           sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
+           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
+           sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
+C
+         ENDIF
+C
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,L)
+         ELSE
+           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+         ENDIF
+C
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+           sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM
+           sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
+           sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
+C
+         ELSE
+C
+           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+           S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+           sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV)
+     +                  +3.*TEMPTM
+           sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
+           sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
+C
+         ENDIF
+C
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+C
+C-------------------------------------------------------------
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+
+c     DO 9999 l = 1, llm
+c     DO 9999 j = 1, jjp1
+c     DO 9999 i = 1, iip1
+c        IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
+c           PRINT*, '-------------------'
+c           PRINT*, 'En fin de ADVZ'
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c           print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c           print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c           print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c           WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1'
+c            STOP
+c        ENDIF
+ 9999 CONTINUE
+
+C *** ------------------- bouclage cyclique  en X ------------
+      
+c      DO l = 1,llm
+c         DO j = 1,jjp1
+c            SM(iip1,j,l) = SM(1,j,l)
+c            S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+C            sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
+c            sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
+c            sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
+c         ENDDO
+c      ENDDO
+           
+C-------------------------------------------------------------
+C *** Test : diag de la qqtite totale de traceur 
+C            dans l'atmosphere avant l'advection en z
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+cIM 240305            sqf = sqf + S0(i,j,l,9)
+               sqf = sqf + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+      PRINT*,'sqf=', sqf
+
+C-------------------------------------------------------------
+      RETURN
+      END
+C_______________________________________________________________
+C_______________________________________________________________
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/advzp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/advzp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/advzp.F	(revision 984)
@@ -0,0 +1,378 @@
+!
+! $Header$
+!
+      SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ
+     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in Z direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  Source : Pascal Simon ( Meteo, CNRM )                          C
+C  Adaptation : A.A. (LGGE)                                       C
+C  Derniere Modif : 19/11/95 LAST                                 C
+C                                                                 C
+C  sont les arguments d'entree pour le s-pg                       C
+C                                                                 C
+C  argument de sortie du s-pg                                     C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation
+C
+
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+C
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+c
+        INTEGER lon,lat,niv
+        INTEGER i,j,jv,k,kp,l,lp
+        INTEGER ntra
+c        PARAMETER (ntra = 1)
+c
+        REAL dtz
+        REAL w ( iip1,jjp1,llm )
+c
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+     +    ,SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+C
+C  Local :
+C  -------
+C
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+C
+      REAL WGRI(iip1,jjp1,0:llm)
+
+C Rem : UGRI et VGRI ne sont pas utilises dans
+C  cette subroutine ( advection en z uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C         attention a celui de WGRI
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+C  the moments Fij are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+C
+      REAL F0(iim,llm,ntra),FM(iim,llm)
+      REAL FX(iim,llm,ntra),FY(iim,llm,ntra)
+      REAL FZ(iim,llm,ntra)
+      REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra)
+      REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
+      REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim)
+      REAL ALFQ(iim),ALF1Q(iim)
+      REAL ALF2(iim),ALF3(iim)
+      REAL ALF4(iim)
+      REAL TEMPTM          ! Just temporal variable
+      REAL SLPMAX,S1MAX,S1NEW,S2NEW
+c
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv = llm         !       tab. S et VGRI 
+                    
+c-----------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+c 
+      sqi = 0.
+      sqf = 0.
+c
+      DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqi = sqi + S0(i,j,l,ntra)
+           END DO
+         END DO
+      END DO
+      PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
+      PRINT*,'sqi=',sqi
+
+c-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion des flux de masses en kg
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+            wgri (i,j,llm+1-l) = w (i,j,l)  
+  500 CONTINUE
+      do j=1,jjp1
+         do i=1,iip1
+            wgri(i,j,0)=0.
+         enddo
+      enddo
+c
+cAA rem : Je ne suis pas sur du signe  
+cAA       Je ne suis pas sur pour le 0:llm
+c
+c-----------------------------------------------------------------
+C---------------------- START HERE -------------------------------
+C
+C  boucle sur les latitudes
+C
+      DO 1 K=1,LAT
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 101
+C
+      DO 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            IF(S0(I,K,L,JV).GT.0.) THEN
+              SLPMAX=S0(I,K,L,JV)
+              S1MAX =1.5*SLPMAX
+              S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
+              S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                     AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
+              SZ (I,K,L,JV)=S1NEW
+              SZZ(I,K,L,JV)=S2NEW
+              SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
+              SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+            ELSE
+              SZ (I,K,L,JV)=0.
+              SZZ(I,K,L,JV)=0.
+              SSXZ(I,K,L,JV)=0.
+              SYZ(I,K,L,JV)=0.
+            ENDIF
+ 100     CONTINUE
+ 10   CONTINUE
+C
+ 101  CONTINUE
+C
+C  boucle sur les niveaux intercouches de 1 a NIV-1
+C   (flux nul au sommet L=0 et a la base L=NIV)
+C
+C  calculate flux and moments between adjacent boxes
+C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+      DO 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           FM(I,L)=-WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+         ELSE
+           FM(I,L)=WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,L)
+         ENDIF
+C
+         ALFQ (I)=ALF(I)*ALF(I)
+         ALF1 (I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2 (I)=ALF1(I)-ALF(I)
+         ALF3 (I)=ALF(I)*ALFQ(I)
+         ALF4 (I)=ALF1(I)*ALF1Q(I)
+C
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)*
+     +          ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
+           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
+           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
+           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
+           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
+           FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
+           FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
+           FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
+           FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
+           FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
+C
+           S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
+           SZ (I,K,LP,JV)=ALF1Q(I)
+     +                   *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
+           SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
+           SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
+           SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
+           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
+           SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
+           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
+           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
+           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
+C
+         ELSE
+C
+           F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV)
+     +           +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
+           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
+           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
+           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
+           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
+           FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
+           FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
+           FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
+           FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
+           FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
+           SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
+           SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
+           SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
+           SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
+           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
+           SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
+C
+         ENDIF
+C
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,L)
+         ELSE
+           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+         ENDIF
+C
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF(I)*ALF1(I)
+         ALF3(I)=ALF1(I)-ALF(I)
+C
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+           S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+           SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV)
+     +        +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
+           SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV)
+     +                  +3.*TEMPTM
+           SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV)
+     +              +3.*(ALF1(I)*FX (I,L,JV)-ALF  (I)*SSX (I,K,L,JV))
+           SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV)
+     +              +3.*(ALF1(I)*FY (I,L,JV)-ALF  (I)*SY (I,K,L,JV))
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
+           SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
+           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
+           SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
+C
+         ELSE
+C
+           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+           S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+           SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV)
+     +        +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
+           SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV)
+     +                   +3.*TEMPTM
+           SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV)
+     +                   +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
+           SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV)
+     +                   +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
+           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
+           SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
+           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
+           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
+           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
+C
+         ENDIF
+C
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+C
+      DO l = 1,llm
+      DO j = 1,jjp1
+          SM(iip1,j,l) = SM(1,j,l)
+	  S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+          SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+	  SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+          SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+      ENDDO
+      ENDDO
+c										C-------------------------------------------------------------
+C *** Test : diag de la qqtite totale de tarceur
+C            dans l'atmosphere avant l'advection en z
+       DO l = 1,llm
+       DO j = 1,jjp1
+       DO i = 1,iim
+          sqf = sqf + S0(i,j,l,ntra)
+       ENDDO
+       ENDDO
+       ENDDO
+       PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+       PRINT*,'sqf=', sqf
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/bernoui.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/bernoui.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/bernoui.F	(revision 984)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c     calcul de la fonction de Bernouilli aux niveaux s  .....
+c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
+c                              energ.cinet.)
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Decalrations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+c
+c   Arguments:
+c   ----------
+c
+      INTEGER nlay,ngrid
+      REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay)
+c
+c   Local:
+c   ------
+c
+      INTEGER   ijl
+c
+c-----------------------------------------------------------------------
+c   calcul de Bernouilli:
+c   ---------------------
+c
+      DO 4 ijl = 1,ngrid*nlay
+         pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
+   4  CONTINUE
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+      CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/bilan_dyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/bilan_dyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/bilan_dyn.F	(revision 984)
@@ -0,0 +1,584 @@
+!
+! $Header$
+!
+      SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum,
+     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+c   AFAIRE
+c   Prevoir en champ nq+1 le diagnostique de l'energie
+c   en faisant Qzon=Cv T + L * ...
+c             vQ..A=Cp T + L * ...
+
+      USE IOIPSL
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.h"
+#include "iniprint.h"
+
+c====================================================================
+c
+c   Sous-programme consacre à des diagnostics dynamiques de base
+c
+c 
+c   De facon generale, les moyennes des scalaires Q sont ponderees par
+c   la masse.
+c
+c   Les flux de masse sont eux simplement moyennes.
+c
+c====================================================================
+
+c   Arguments :
+c   ===========
+
+      integer ntrac
+      real dt_app,dt_cum
+      real ps(iip1,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+      real flux_u(iip1,jjp1,llm)
+      real flux_v(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+      real phi(iip1,jjp1,llm)
+      real ucov(iip1,jjp1,llm)
+      real vcov(iip1,jjm,llm)
+      real trac(iip1,jjp1,llm,ntrac)
+
+c   Local :
+c   =======
+
+      integer icum,ncum
+      logical first
+      real zz,zqy,zfactv(jjm,llm)
+
+      integer nQ
+      parameter (nQ=7)
+
+
+cym      character*6 nom(nQ)
+cym      character*6 unites(nQ)
+      character*6,save :: nom(nQ)
+      character*6,save :: unites(nQ)
+
+      character*10 file
+      integer ifile
+      parameter (ifile=4)
+
+      integer itemp,igeop,iecin,iang,iu,iovap,iun
+      integer i_sortie
+
+      save first,icum,ncum
+      save itemp,igeop,iecin,iang,iu,iovap,iun
+      save i_sortie
+
+      real time
+      integer itau
+      save time,itau
+      data time,itau/0.,0/
+
+      data first/.true./
+      data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
+      data i_sortie/1/
+
+      real ww
+
+c   variables dynamiques intermédiaires
+      REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+      REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL vorpot(iip1,jjm,llm)
+      REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
+      REAL bern(iip1,jjp1,llm)
+
+c   champ contenant les scalaires advectés.
+      real Q(iip1,jjp1,llm,nQ)
+    
+c   champs cumulés
+      real ps_cum(iip1,jjp1)
+      real masse_cum(iip1,jjp1,llm)
+      real flux_u_cum(iip1,jjp1,llm)
+      real flux_v_cum(iip1,jjm,llm)
+      real Q_cum(iip1,jjp1,llm,nQ)
+      real flux_uQ_cum(iip1,jjp1,llm,nQ)
+      real flux_vQ_cum(iip1,jjm,llm,nQ)
+      real flux_wQ_cum(iip1,jjp1,llm,nQ)
+      real dQ(iip1,jjp1,llm,nQ)
+
+      save ps_cum,masse_cum,flux_u_cum,flux_v_cum
+      save Q_cum,flux_uQ_cum,flux_vQ_cum
+
+c   champs de tansport en moyenne zonale
+      integer ntr,itr
+      parameter (ntr=5)
+
+cym      character*10 znom(ntr,nQ)
+cym      character*20 znoml(ntr,nQ)
+cym      character*10 zunites(ntr,nQ)
+      character*10,save :: znom(ntr,nQ)
+      character*20,save :: znoml(ntr,nQ)
+      character*10,save :: zunites(ntr,nQ)
+
+      integer iave,itot,immc,itrs,istn
+      data iave,itot,immc,itrs,istn/1,2,3,4,5/
+      character*3 ctrs(ntr)
+      data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+      real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+      real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+      real zmasse(jjm,llm),zamasse(jjm)
+
+      real zv(jjm,llm),psi(jjm,llm+1)
+
+      integer i,j,l,iQ
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      character*10 infile
+
+      integer fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      integer ndex3d(jjm*llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer ii,jj
+      integer zan, dayref
+C
+      real rlong(jjm),rlatg(jjm)
+
+
+
+c=====================================================================
+c   Initialisation
+c=====================================================================
+
+      time=time+dt_app
+      itau=itau+1
+cIM
+      ndex3d=0
+
+      if (first) then
+
+
+        icum=0
+c       initialisation des fichiers
+        first=.false.
+c   ncum est la frequence de stokage en pas de temps
+        ncum=dt_cum/dt_app
+        if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+           WRITE(lunout,*)
+     .            'Pb : le pas de cumule doit etre multiple du pas'
+           WRITE(lunout,*)'dt_app=',dt_app
+           WRITE(lunout,*)'dt_cum=',dt_cum
+           stop
+        endif
+
+        if (i_sortie.eq.1) then
+         file='dynzon'
+         call inigrads(ifile,1
+     s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dt_cum,file,'dyn_zon ')
+        endif
+
+        nom(itemp)='T'
+        nom(igeop)='gz'
+        nom(iecin)='K'
+        nom(iang)='ang'
+        nom(iu)='u'
+        nom(iovap)='ovap'
+        nom(iun)='un'
+
+        unites(itemp)='K'
+        unites(igeop)='m2/s2'
+        unites(iecin)='m2/s2'
+        unites(iang)='ang'
+        unites(iu)='m/s'
+        unites(iovap)='kg/kg'
+        unites(iun)='un'
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      infile='dynzon'
+
+      zan = annee_ref
+      dayref = day_ref
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      rlong=0.
+      rlatg=rlatv*180./pi
+       
+      call histbeg(infile, 1, rlong, jjm, rlatg,
+     .             1, 1, 1, jjm,
+     .             tau0, zjulian, dt_cum, thoriid, fileid)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
+     .              llm, presnivs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+      do iQ=1,nQ
+         do itr=1,ntr
+            if(itr.eq.1) then
+               znom(itr,iQ)=nom(iQ)
+               znoml(itr,iQ)=nom(iQ)
+               zunites(itr,iQ)=unites(iQ)
+            else
+               znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+               znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+               zunites(itr,iQ)='m/s * '//unites(iQ)
+            endif
+         enddo
+      enddo
+
+c   Declarations des champs avec dimension verticale
+c      print*,'1HISTDEF'
+      do iQ=1,nQ
+         do itr=1,ntr
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'var ',itr,iQ
+     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+            call histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+c   Declarations pour les fonctions de courant
+c      print*,'2HISTDEF'
+          call histdef(fileid,'psi'//nom(iQ)
+     .      ,'stream fn. '//znoml(itot,iQ),
+     .      zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+      enddo
+
+
+c   Declarations pour les champs de transport d'air
+c      print*,'3HISTDEF'
+      call histdef(fileid, 'masse', 'masse',
+     .             'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'v', 'v',
+     .             'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+c   Declarations pour les fonctions de courant
+c      print*,'4HISTDEF'
+          call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
+     .      1,jjm,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+
+
+c   Declaration des champs 1D de transport en latitude
+c      print*,'5HISTDEF'
+      do iQ=1,nQ
+         do itr=2,ntr
+            call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+      enddo
+
+
+c      print*,'8HISTDEF'
+               CALL histend(fileid)
+
+
+      endif
+
+
+c=====================================================================
+c   Calcul des champs dynamiques
+c   ----------------------------
+
+c   énergie cinétique
+      ucont(:,:,:)=0
+      CALL covcont(llm,ucov,vcov,ucont,vcont)
+      CALL enercin(vcov,ucov,vcont,ucont,ecin)
+
+c   moment cinétique
+      do l=1,llm
+         ang(:,:,l)=ucov(:,:,l)+constang(:,:)
+         unat(:,:,l)=ucont(:,:,l)*cu(:,:)
+      enddo
+
+      Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp
+      Q(:,:,:,igeop)=phi(:,:,:)
+      Q(:,:,:,iecin)=ecin(:,:,:)
+      Q(:,:,:,iang)=ang(:,:,:)
+      Q(:,:,:,iu)=unat(:,:,:)
+      Q(:,:,:,iovap)=trac(:,:,:,1)
+      Q(:,:,:,iun)=1.
+
+
+c=====================================================================
+c   Cumul
+c=====================================================================
+c
+      if(icum.EQ.0) then
+         ps_cum=0.
+         masse_cum=0.
+         flux_u_cum=0.
+         flux_v_cum=0.
+         Q_cum=0.
+         flux_vQ_cum=0.
+         flux_uQ_cum=0.
+      endif
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+      icum=icum+1
+
+c   accumulation des flux de masse horizontaux
+      ps_cum=ps_cum+ps
+      masse_cum=masse_cum+masse
+      flux_u_cum=flux_u_cum+flux_u
+      flux_v_cum=flux_v_cum+flux_v
+      do iQ=1,nQ
+      Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:)
+      enddo
+
+c=====================================================================
+c  FLUX ET TENDANCES
+c=====================================================================
+
+c   Flux longitudinal
+c   -----------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=1,jjp1
+               do i=1,iim
+                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
+     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+               enddo
+               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+            enddo
+         enddo
+      enddo
+
+c    flux méridien
+c    -------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=1,jjm
+               do i=1,iip1
+                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
+     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+               enddo
+            enddo
+         enddo
+      enddo
+
+
+c    tendances
+c    ---------
+
+c   convergence horizontale
+      call  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+c   calcul de la vitesse verticale
+      call convmas(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert(convm,w)
+
+      do iQ=1,nQ
+         do l=1,llm-1
+            do j=1,jjp1
+               do i=1,iip1
+                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+               enddo
+            enddo
+         enddo
+      enddo
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+c=====================================================================
+c   PAS DE TEMPS D'ECRITURE
+c=====================================================================
+      if (icum.eq.ncum) then
+c=====================================================================
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Pas d ecriture'
+
+c   Normalisation
+      do iQ=1,nQ
+         Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
+      enddo
+      zz=1./float(ncum)
+      ps_cum=ps_cum*zz
+      masse_cum=masse_cum*zz
+      flux_u_cum=flux_u_cum*zz
+      flux_v_cum=flux_v_cum*zz
+      flux_uQ_cum=flux_uQ_cum*zz
+      flux_vQ_cum=flux_vQ_cum*zz
+      dQ=dQ*zz
+
+
+c   A retravailler eventuellement
+c   division de dQ par la masse pour revenir aux bonnes grandeurs
+      do iQ=1,nQ
+         dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:)
+      enddo
+ 
+c=====================================================================
+c   Transport méridien
+c=====================================================================
+
+c   cumul zonal des masses des mailles
+c   ----------------------------------
+      zv=0.
+      zmasse=0.
+      call massbar(masse_cum,massebx,masseby)
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+               zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+            enddo
+            zfactv(j,l)=cv(1,j)/zmasse(j,l)
+         enddo
+      enddo
+
+c     print*,'3OK'
+c   --------------------------------------------------------------
+c   calcul de la moyenne zonale du transport :
+c   ------------------------------------------
+c
+c                                     --
+c TOT : la circulation totale       [ vq ]
+c
+c                                      -     -
+c MMC : mean meridional circulation [ v ] [ q ]
+c
+c                                     ----      --       - -
+c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+c
+c                                     - * - *       - -       -     -
+c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+c
+c                                              - -
+c    on utilise aussi l'intermediaire TMP :  [ v q ]
+c
+c    la variable zfactv transforme un transport meridien cumule
+c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+c
+c   --------------------------------------------------------------
+
+
+c   ----------------------------------------
+c   Transport dans le plan latitude-altitude
+c   ----------------------------------------
+
+      zvQ=0.
+      psiQ=0.
+      do iQ=1,nQ
+         zvQtmp=0.
+         do l=1,llm
+            do j=1,jjm
+c              print*,'j,l,iQ=',j,l,iQ
+c   Calcul des moyennes zonales du transort total et de zvQtmp
+               do i=1,iim
+                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
+     s                            +flux_vQ_cum(i,j,l,iQ)
+                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
+     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
+     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+               enddo
+c              print*,'aOK'
+c   Decomposition
+               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+            enddo
+         enddo
+c   fonction de courant meridienne pour la quantite Q
+         do l=llm,1,-1
+            do j=1,jjm
+               psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+            enddo
+         enddo
+      enddo
+
+c   fonction de courant pour la circulation meridienne moyenne
+      psi=0.
+      do l=llm,1,-1
+         do j=1,jjm
+            psi(j,l)=psi(j,l+1)+zv(j,l)
+            zv(j,l)=zv(j,l)*zfactv(j,l)
+         enddo
+      enddo
+
+c     print*,'4OK'
+c   sorties proprement dites
+      if (i_sortie.eq.1) then
+      do iQ=1,nQ
+         do itr=1,ntr
+            call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ)
+     s      ,jjm*llm,ndex3d)
+         enddo
+         call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ)
+     s      ,jjm*llm,ndex3d)
+      enddo
+
+      call histwrite(fileid,'masse',itau,zmasse
+     s   ,jjm*llm,ndex3d)
+      call histwrite(fileid,'v',itau,zv
+     s   ,jjm*llm,ndex3d)
+      psi=psi*1.e-9
+      call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
+
+      endif
+
+
+c   -----------------
+c   Moyenne verticale
+c   -----------------
+
+      zamasse=0.
+      do l=1,llm
+         zamasse(:)=zamasse(:)+zmasse(:,l)
+      enddo
+      zavQ=0.
+      do iQ=1,nQ
+         do itr=2,ntr
+            do l=1,llm
+               zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l)
+            enddo
+            zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:)
+            call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ)
+     s      ,jjm*llm,ndex3d)
+         enddo
+      enddo
+
+c     on doit pouvoir tracer systematiquement la fonction de courant.
+
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/caladvtrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/caladvtrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/caladvtrac.F	(revision 984)
@@ -0,0 +1,118 @@
+!
+! $Header$
+!
+c
+c
+            SUBROUTINE caladvtrac(q,pbaru,pbarv ,
+     *                   p ,masse, dq ,  teta,
+     *                   flxw, pk)
+c
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron  
+c
+c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+c=======================================================================
+c
+c       Shema de  Van Leer
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "control.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqmx),dq( ip1jmp1,llm,2 )
+      REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm)
+      REAL               :: flxw(ip1jmp1,llm)
+
+c  ..................................................................
+c
+c  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
+c
+c  ..................................................................
+c
+c   Local:
+c   ------
+
+      EXTERNAL  advtrac,minmaxq, qminimum
+      INTEGER ij,l, iq, iapptrac
+      REAL finmasse(ip1jmp1,llm), dtvrtrac
+
+cc
+c
+C initialisation
+        dq = 0.
+
+        CALL SCOPY( 2 * ijp1llm, q, 1, dq, 1 )
+
+c  test des valeurs minmax
+cc        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
+cc        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
+
+c   advection
+
+        CALL advtrac( pbaru,pbarv, 
+     *       p,  masse,q,iapptrac, teta,
+     .       flxw, pk)
+c
+
+         IF( iapptrac.EQ.iapp_tracvl ) THEN
+c
+cc          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
+cc          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
+
+cc     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
+c
+          DO l = 1, llm
+           DO ij = 1, ip1jmp1
+             finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+           ENDDO
+          ENDDO
+
+          CALL qminimum( q, 2, finmasse )
+
+          CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
+          CALL filtreg ( finmasse ,  jjp1,  llm, -2, 2, .TRUE., 1 )
+c
+c   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
+c   ********************************************************************
+c
+          dtvrtrac = iapp_tracvl * dtvr
+c
+           DO iq = 1 , 2
+            DO l = 1 , llm
+             DO ij = 1,ip1jmp1
+             dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l)
+     *                               /  dtvrtrac
+             ENDDO
+            ENDDO
+           ENDDO
+c
+         ELSE
+           DO iq = 1 , 2
+           DO l  = 1, llm
+             DO ij = 1,ip1jmp1
+              dq(ij,l,iq)  = 0.
+             ENDDO
+           ENDDO
+           ENDDO
+
+
+         ENDIF
+
+c
+
+c  ... On appelle  qminimum uniquement  pour l'eau vapeur et liquide  ..
+
+ 
+      RETURN
+      END
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/caldyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/caldyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/caldyn.F	(revision 984)
@@ -0,0 +1,122 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE caldyn
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      LOGICAL conser
+
+      INTEGER itau
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
+      REAL vorpot(ip1jm,llm)
+      REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+      REAL massebxy(ip1jm,llm)
+    
+
+      INTEGER   ij,l
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+      CALL psextbar (   ps   , psexbarxy                            )
+      CALL massdair (    p   , masse                                )
+      CALL massbar  (   masse, massebx , masseby                    )
+      call massbarxy(   masse, massebxy                             )
+      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      CALL dteta1   (   teta , pbaru   , pbarv, dteta               )
+      CALL convmas  (   pbaru, pbarv   , convm                      )
+
+      DO ij =1, ip1jmp1
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+
+      CALL vitvert ( convm  , w                                  )
+      CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
+      CALL dudv1   ( vorpot , pbaru , pbarv     , du     , dv    )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
+      CALL dudv2   ( teta   , pkf   , bern      , du     , dv    )
+
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+      ENDDO
+      ENDDO
+
+
+      CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta ) 
+
+C  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi 
+C          probablement. Observe sur le code compile avec pgf90 3.0-1 
+
+      DO l = 1, llm
+         DO ij = 1, ip1jm, iip1
+           IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+c         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',  
+c    ,   ' dans caldyn'
+c         PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+          dv(ij+iim,l) = dv(ij,l)
+          endif
+         enddo
+      enddo
+c-----------------------------------------------------------------------
+c   Sorties eventuelles des variables de controle:
+c   ----------------------------------------------
+
+      IF( conser )  THEN
+        CALL sortvarc
+     $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+      ENDIF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/caldyn0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/caldyn0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/caldyn0.F	(revision 984)
@@ -0,0 +1,89 @@
+!
+! $Header$
+!
+      SUBROUTINE caldyn0
+     $ (itau,ucov,vcov,teta,ps,masse,pk,phis ,
+     $  phi,w,pbaru,pbarv,time )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL pk(iip1,jjp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
+      REAL vorpot(ip1jm,llm)
+      REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+      REAL massebxy(ip1jm,llm), dp(ip1jmp1)
+    
+
+      INTEGER   ij,l
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+      CALL psextbar (   ps   , psexbarxy                            )
+      CALL massdair (    p   , masse                                )
+      CALL massbar  (   masse, massebx , masseby                    )
+      CALL massbarxy(   masse, massebxy                             )
+      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      CALL convmas  (   pbaru, pbarv   , convm                      )
+
+      DO ij =1, ip1jmp1
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+
+      CALL vitvert ( convm  , w                                  )
+      CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+         ENDDO
+      ENDDO
+
+        CALL sortvarc0
+     $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/calfis.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/calfis.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/calfis.F	(revision 984)
@@ -0,0 +1,614 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE calfis(nq,
+     $                  lafin,
+     $                  rdayvrai,
+     $                  heure,
+     $                  pucov,
+     $                  pvcov,
+     $                  pteta,
+     $                  pq,
+     $                  pmasse,
+     $                  pps,
+     $                  pp,
+     $                  ppk,
+     $                  pphis,
+     $                  pphi,
+     $                  pducov,
+     $                  pdvcov,
+     $                  pdteta,
+     $                  pdq,
+     $                  flxw,
+     $                  clesphy0,
+     $                  pdufi,
+     $                  pdvfi,
+     $                  pdhfi,
+     $                  pdqfi,
+     $                  pdpsfi)
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+
+      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"
+#include "advtrac.h"
+
+      INTEGER ngridmx,nq
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+
+c    Arguments :
+c    -----------
+      LOGICAL  lafin
+      REAL heure
+
+      REAL pvcov(iip1,jjm,llm)
+      REAL pucov(iip1,jjp1,llm)
+      REAL pteta(iip1,jjp1,llm)
+      REAL pmasse(iip1,jjp1,llm)
+      REAL pq(iip1,jjp1,llm,nqmx)
+      REAL pphis(iip1,jjp1)
+      REAL pphi(iip1,jjp1,llm)
+c
+      REAL pdvcov(iip1,jjm,llm)
+      REAL pducov(iip1,jjp1,llm)
+      REAL pdteta(iip1,jjp1,llm)
+      REAL pdq(iip1,jjp1,llm,nqmx)
+c
+      REAL pps(iip1,jjp1)
+      REAL pp(iip1,jjp1,llmp1)
+      REAL ppk(iip1,jjp1,llm)
+c
+      REAL pdvfi(iip1,jjm,llm)
+      REAL pdufi(iip1,jjp1,llm)
+      REAL pdhfi(iip1,jjp1,llm)
+      REAL pdqfi(iip1,jjp1,llm,nqmx)
+      REAL pdpsfi(iip1,jjp1)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+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,nqmx)
+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,nqmx)
+      REAL zdpsrf(ngridmx)
+c
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+c
+cIM diagnostique PVteta, Amip2
+      INTEGER ntetaSTD
+      PARAMETER(ntetaSTD=3)
+      REAL rtetaSTD(ntetaSTD)
+      DATA rtetaSTD/350., 380., 405./
+      REAL PVteta(ngridmx,ntetaSTD)
+c
+      REAL flxw(iip1,jjp1,llm)  ! Flux de masse verticale sur la grille dynamique
+      REAL flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
+c
+      
+      REAL SSUM
+
+      LOGICAL firstcal, debut
+      DATA firstcal/.true./
+      SAVE firstcal,debut
+      REAL rdayvrai
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+      IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         PRINT*,'STOP dans calfis'
+         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         PRINT*,'  ngridmx  jjm   iim   '
+         PRINT*,ngridmx,jjm,iim
+         STOP
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   latitude, longitude et aires des mailles pour la physique:
+c   ----------------------------------------------------------
+
+c
+      IF ( firstcal )  THEN
+          debut = .TRUE.
+      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   ----------------------------------
+
+       
+      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,nq
+          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"
+
+      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
+
+
+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
+cIM calcul PV a teta=350, 380, 405K
+      CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
+     $           ztfi,zplay,zplev,
+     $           ntetaSTD,rtetaSTD,PVteta)
+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   ---------------------
+
+
+      CALL physiq (ngridmx,
+     .             llm,
+     .             nq,
+     .             debut,
+     .             lafin,
+     .             rdayvrai,
+     .             heure,
+     .             dtphys,
+     .             zplev,
+     .             zplay,
+     .             zphi,
+     .             zphis,
+     .             presnivs,
+     .             clesphy0,
+     .             zufi,
+     .             zvfi,
+     .             ztfi,
+     .             zqfi,
+     .             flxwfi,
+     .             zdufi,
+     .             zdvfi,
+     .             zdtfi,
+     .             zdqfi,
+     .             zdpsrf,
+cIM diagnostique PVteta, Amip2          
+     .             pducov,
+     .             PVteta)
+
+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   ---------------------
+
+      DO iq=1,nqmx
+         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,nq
+         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: LMDZ4/tags/LF_20080728/libf/dyn3d/clesph0.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/clesph0.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/clesph0.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+c..include clesph0.h
+c
+       COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr ,
+     ,                ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con
+c
+       LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/coefpoly.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/coefpoly.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/coefpoly.F	(revision 984)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 ,
+     ,                                          a0,a1,a2,a3         )
+      IMPLICIT NONE
+c
+c   ...  Auteur :   P. Le Van  ...
+c
+c
+c    Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui
+c      satisfait aux 4 equations  suivantes :
+
+c    a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1
+c    a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2
+c               a1  +     2.*a2*xtild1 +     3.*a3*xtild1*xtild1 = Xprim1
+c               a1  +     2.*a2*xtild2 +     3.*a3*xtild2*xtild2 = Xprim2
+
+c  On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3
+
+      REAL*8 Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi 
+      REAL*8 Xfout, Xprim
+      REAL*8 a1,a2,a3,a0, 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
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/com_io_dyn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/com_io_dyn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/com_io_dyn.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      integer histid, histvid, histaveid
+      common/com_io_dyn/histid, histvid, histaveid
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comconst.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comconst.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comconst.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comconst.h
+
+      COMMON/comconst/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl,
+     * dtvr,daysec,
+     * pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr,daysec
+      REAL pi,dtphys,dtdiss,rad,r,cpp,kappa
+      REAL cotot,unsim,g,omeg
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comdiss.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comdiss.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comdiss.h	(revision 984)
@@ -0,0 +1,15 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'comdiss.h'
+
+      INTEGER niter
+      REAL tetau(llm),tetah(llm),cdivu,cdivh,crot
+      LOGICAL dissipst
+
+      COMMON/comdissi/niter
+      COMMON/comdissr/tetau,tetah,cdivu,cdivh,crot
+      COMMON/comdissl/dissipst
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comdissip.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comdissip.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comdissip.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE dissip.h
+
+      COMMON/comdissip/
+     $    lstardis,niterdis,coefdis,tetavel,tetatemp,gamdissip
+
+
+      LOGICAL lstardis
+      INTEGER niterdis
+
+      REAL tetavel,tetatemp,coefdis,gamdissip
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comdissipn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comdissipn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comdissipn.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comdissipn.h
+
+      REAL  tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
+c
+      COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm)   ,
+     1                        cdivu,      crot,         cdivh
+
+c
+c    Les parametres de ce common proviennent des calculs effectues dans 
+c             Inidissip  .
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comdissnew.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comdissnew.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comdissnew.h	(revision 984)
@@ -0,0 +1,18 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comdissnew.h
+
+      COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv,
+     1                   tetagrot,tetatemp,coefdis 
+
+      LOGICAL lstardis
+      INTEGER nitergdiv, nitergrot, niterh
+      REAL     tetagdiv, tetagrot,  tetatemp, coefdis
+
+c
+c ... Les parametres de ce common comdissnew sont  lues par defrun_new 
+c              sur le fichier  run.def    ....
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comgeom.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comgeom.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comgeom.h	(revision 984)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+*CDK comgeom
+      COMMON/comgeom/
+     1 cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),
+     2 aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),
+     3 airev(ip1jm),unsaire(ip1jmp1),apoln,apols,
+     4 unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),
+     5 aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),
+     6 aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),
+     7 alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),
+     8 alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),
+     9 fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),
+     1 rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),
+     1 cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),
+     2 cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),
+     3 cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),
+     4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,
+     5 unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),
+     6 aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+c
+        REAL 
+     1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,
+     2 apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,
+     3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2 
+     6 ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,
+     7 aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu
+     8 , xprimv
+c
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comgeom2.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comgeom2.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comgeom2.h	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+*CDK comgeom2
+      COMMON/comgeom/
+     1 cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm)  ,
+     2 aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1)           ,
+     3 airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols                 ,  
+     4 unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm)       ,
+     5 aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1)       ,
+     6 aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1)         ,
+     7 alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1)        ,
+     8 alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1)    ,
+     9 fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm),
+     1 rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm)  ,
+     1 cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1)                        ,
+     2 cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1),
+     3 cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) ,
+     4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2                ,
+     5 unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1)                  ,
+     6 unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm)
+     7 , xprimu(iip1),xprimv(iip1)
+
+c
+      REAL 
+     1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire
+     2 ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4     ,
+     3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1           , 
+     6 unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2     ,
+     7 unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu    ,
+     8 cusurcvu,xprimu,xprimv
+c
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/comvert.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/comvert.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/comvert.h	(revision 984)
@@ -0,0 +1,12 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c   INCLUDE 'comvert.h'
+
+      COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm) ,
+     ,               pa,preff,nivsigs(llm),nivsig(llm+1)
+
+      REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/conf_dat2d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/conf_dat2d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/conf_dat2d.F	(revision 984)
@@ -0,0 +1,221 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd ,
+     ,                           interbar                        )
+c
+c     Auteur :  P. Le Van
+
+c    Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que
+c       qu'on ait     - pi    a    pi    en longitude
+c       et qu'on ait   pi/2.  a - pi/2.  en latitude
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c      modifiees pour etre configurees comme ci-dessus .
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      INTEGER lons,lats
+      CHARACTER*25 title
+      REAL xd(lons),yd(lats)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons),yf(lats)
+c
+c    ***  Arguments en entree et  sortie ***
+      REAL champd(lons,lats)
+
+c   ***     Variables  locales  ***
+c
+      REAL pi,pis2,depi
+      LOGICAL radianlon, invlon ,radianlat, invlat, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind
+
+      REAL, ALLOCATABLE :: xtemp(:) 
+      REAL, ALLOCATABLE :: ytemp(:) 
+      REAL, ALLOCATABLE :: champf(:,:)
+     
+c
+c      WRITE(6,*) ' conf_dat2d  pour la variable ', title
+
+      ALLOCATE( xtemp(lons) )
+      ALLOCATE( ytemp(lats) )
+      ALLOCATE( champf(lons,lats) )
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+            radianlon = .FALSE.
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        IF ( invlon )   THEN
+
+           DO j = 1, lats
+            DO i = 1,lons
+             champf(i,j) = champd(i,j)
+            ENDDO
+           ENDDO
+
+           DO i = 1 ,lons
+            xf(i) = xtemp(i)
+           ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+           DO i=1,lons
+            IF( xf(i).GT. pi )  THEN
+            GO TO 88
+            ENDIF
+           ENDDO
+
+88         CONTINUE
+c
+           ip180 = i
+
+           DO i = 1,lons
+            IF (xf(i).GT. pi)  THEN
+             xf(i) = xf(i) - depi
+            ENDIF
+           ENDDO
+
+           DO i= ip180,lons
+            ind = i-ip180 +1
+            xtemp(ind) = xf(i)
+           ENDDO
+
+           DO i= ind +1,lons
+            xtemp(i) = xf(i-ind)
+           ENDDO
+
+c   .....    on tourne les longitudes  pour  champf ....
+c
+           DO j = 1,lats
+
+             DO i = ip180,lons
+              ind  = i-ip180 +1
+              champd (ind,j) = champf (i,j)
+             ENDDO
+   
+             DO i= ind +1,lons
+              champd (i,j)  = champf (i-ind,j)
+             ENDDO
+
+           ENDDO
+
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+
+         IF ( invlat )    THEN
+
+           DO j = 1,lats
+            yf(j) = ytemp(j)
+           ENDDO
+
+           DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j) = champd(i,j)
+             ENDDO
+           ENDDO
+
+           DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1) = champf (i,j)
+              ENDDO
+           ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+
+c        
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+
+      ENDIF
+c
+        DEALLOCATE(champf)
+
+       DO i = 1, lons
+        xf(i) = xtemp(i)
+       ENDDO
+       DO j = 1, lats
+        yf(j) = ytemp(j)
+       ENDDO
+
+      deallocate(xtemp)
+      deallocate(ytemp)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/conf_dat3d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/conf_dat3d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/conf_dat3d.F	(revision 984)
@@ -0,0 +1,296 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf,
+     ,                                 champd , interbar             )
+c
+c     Auteur : P. Le Van
+c
+c    Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon 
+c       qu'on ait     - pi    a    pi    en longitude
+c       qu'on ait      pi/2.  a - pi/2.  en latitude
+c      et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos.
+c           (     en Pascals   ) .
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      zd  les pressions initiales
+c
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c       modifiees pour etre configurees comme ci-dessus .
+c      zf  les pressions en sortie
+c
+c      champd   en meme temps le champ initial et  final
+c
+c      interbar = .TRUE.  si on appelle l'interpo. barycentrique inter_barxy
+c          sinon , l'interpolation   grille_m  ( grid_atob ) .
+c
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      CHARACTER*(*) :: title
+      INTEGER lons, lats, levs
+      REAL xd(lons), yd(lats), zd(levs)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons), yf(lats), zf(levs)
+
+c    ***  Arguments en entree et  sortie ***
+      REAL  champd(lons,lats,levs)
+
+c    ***  Variables locales  ***
+c
+      REAL pi,pis2,depi,presmax
+      LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind,l
+
+      REAL, ALLOCATABLE :: xtemp(:)
+      REAL, ALLOCATABLE :: ytemp(:)
+      REAL, ALLOCATABLE :: ztemp(:)
+      REAL, ALLOCATABLE :: champf(:,:,:)
+     
+
+c      WRITE(6,*) '  Conf_dat3d  pour  ',title
+
+      ALLOCATE(xtemp(lons))
+      ALLOCATE(ytemp(lats))
+      ALLOCATE(ztemp(levs))
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+      DO l = 1, levs
+       ztemp(l) = zd(l)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        alloc =.FALSE.
+
+        IF ( invlon )   THEN
+
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+
+            DO i = 1 ,lons
+             xf(i) = xtemp(i)
+            ENDDO
+
+            DO l = 1, levs
+             DO j = 1, lats
+              DO i= 1, lons
+               champf (i,j,l)  = champd (i,j,l)
+              ENDDO
+             ENDDO
+            ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+            DO i=1,lons
+             IF( xf(i).GT. pi )  THEN
+              GO TO 88
+             ENDIF
+            ENDDO
+
+88          CONTINUE
+c
+            ip180 = i
+
+            DO i = 1,lons
+             IF (xf(i).GT. pi)  THEN
+              xf(i) = xf(i) - depi
+             ENDIF
+            ENDDO
+
+            DO i= ip180,lons
+             ind = i-ip180 +1
+             xtemp(ind) = xf(i)
+            ENDDO
+
+            DO i= ind +1,lons
+             xtemp(i) = xf(i-ind)
+            ENDDO
+
+c   .....    on tourne les longitudes  pour champf  ....
+c
+            DO l = 1,levs
+              DO j = 1,lats
+               DO i = ip180,lons
+                ind  = i-ip180 +1
+                champd (ind,j,l) = champf (i,j,l)
+               ENDDO
+   
+               DO i= ind +1,lons
+                champd (i,j,l)  = champf (i-ind,j,l)
+               ENDDO
+              ENDDO
+            ENDDO
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+         
+         IF ( invlat )    THEN
+
+           IF(.NOT.alloc)  THEN 
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+           ENDIF
+
+           DO j = 1, lats
+            yf(j) = ytemp(j)
+           ENDDO
+         
+           DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+
+            DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1,l) = champf (i,j,l)
+              ENDDO
+            ENDDO
+          ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+c
+c
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+      ENDIF
+c
+
+      invlev = .FALSE.
+      IF( ztemp(1).LT.ztemp(levs) )  invlev = .TRUE.
+
+      presmax = MAX( ztemp(1), ztemp(levs) )
+      IF( presmax.LT.1200. ) THEN
+         DO l = 1,levs
+           ztemp(l) = ztemp(l) * 100.
+         ENDDO
+      ENDIF
+
+      IF( invlev )  THEN
+
+          IF(.NOT.alloc)  THEN
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+          ENDIF
+
+          DO l = 1,levs
+            zf(l) = ztemp(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+          DO l = 1,levs
+            ztemp(levs+1-l) = zf(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champd(i,j,levs+1-l) = champf(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+
+      ENDIF
+
+         IF(alloc)  DEALLOCATE(champf)
+
+         DO i = 1, lons
+           xf(i) = xtemp(i)
+         ENDDO
+         DO j = 1, lats
+           yf(j) = ytemp(j)
+         ENDDO
+         DO l = 1, levs
+           zf(l) = ztemp(l)
+         ENDDO
+
+      DEALLOCATE(xtemp)
+      DEALLOCATE(ytemp)
+      DEALLOCATE(ztemp)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/conf_gcm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/conf_gcm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/conf_gcm.F	(revision 984)
@@ -0,0 +1,712 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
+c
+      use IOIPSL
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! #include "clesphys.h"
+#include "iniprint.h"
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy, tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+!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)
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = raz_date
+!Config  Desc = Remise a zero de la date initiale
+!Config  Def  = 0 (pas de remise a zero)
+!Config  Help = Remise a zero de la date initiale 
+!Config         0 pas de remise a zero, on garde la date du fichier restart
+!Config         1 prise en compte de la date de gcm.def avec remise a zero
+!Config         des compteurs de pas de temps
+      raz_date = 0
+      CALL getin('raz_date', raz_date)
+
+!Config  Key  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps)
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+!Config  Key  = iapp_tracvl
+!Config  Desc = frequence du groupement des flux 
+!Config  Def  = iperiod
+!Config  Help = frequence du groupement des flux (en pas de temps) 
+       iapp_tracvl = iperiod
+       CALL getin('iapp_tracvl',iapp_tracvl)
+
+!Config  Key  = iconser
+!Config  Desc = periode de sortie des variables de controle
+!Config  Def  = 240  
+!Config  Help = periode de sortie des variables de controle
+!Config         (En pas de temps)
+       iconser = 240  
+       CALL getin('iconser', iconser)
+
+!Config  Key  = iecri
+!Config  Desc = periode d'ecriture du fichier histoire
+!Config  Def  = 1
+!Config  Help = periode d'ecriture du fichier histoire (en jour) 
+       iecri = 1
+       CALL getin('iecri',iecri)
+
+
+!Config  Key  = periodav
+!Config  Desc = periode de stockage fichier histmoy
+!Config  Def  = 1
+!Config  Help = periode de stockage fichier histmoy (en jour) 
+       periodav = 1.
+       CALL getin('periodav',periodav)
+
+!Config  Key  = idissip
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 10
+!Config  Help = periode de la dissipation 
+!Config         (en pas) ... a completer !
+       idissip = 10
+       CALL getin('idissip',idissip)
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+!Config  Key  = coefdis
+!Config  Desc = coefficient pour gamdissip
+!Config  Def  = 0
+!Config  Help = coefficient pour gamdissip  
+       coefdis = 0.
+       CALL getin('coefdis',coefdis)
+
+!Config  Key  = purmats
+!Config  Desc = Schema d'integration
+!Config  Def  = n
+!Config  Help = Choix du schema d'integration temporel.
+!Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+       purmats = .FALSE.
+       CALL getin('purmats',purmats)
+
+!Config  Key  = ok_guide
+!Config  Desc = Guidage
+!Config  Def  = n
+!Config  Help = Guidage
+       ok_guide = .FALSE.
+       CALL getin('ok_guide',ok_guide)
+
+c    ...............................................................
+
+!Config  Key  = iflag_phys
+!Config  Desc = Avec ls physique 
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       iflag_phys = 1
+       CALL getin('iflag_phys',iflag_phys)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+!Config  Key  = ip_ebil_dyn
+!Config  Desc = PRINT level for energy conserv. diag.
+!Config  Def  = 0
+!Config  Help = PRINT level for energy conservation diag. ;
+!               les options suivantes existent :
+!Config         0 pas de print
+!Config         1 pas de print
+!Config         2 print,
+       ip_ebil_dyn = 0
+       CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+!
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clonn = 0.
+       CALL getin('clon',clonn)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clatt = 0.
+       CALL getin('clat',clatt)
+
+c
+c
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        PRINT *,' La valeur de clat passee par run.def est differente de 
+     *  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismxx = 1.0
+       CALL getin('grossismx',grossismxx)
+
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de grossismx passee par run.def est differente  
+     *  de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismyy = 1.0
+       CALL getin('grossismy',grossismyy)
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        PRINT *,' La valeur de grossismy passee par run.def est differen
+     * te de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      PRINT *,' alphax alphay defrun ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' *** fxyhypb lu sur le fichier start est F ',
+     *       'alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' ***  fxyhypb lu sur le fichier start est T ',
+     *        'alors  qu il est  F  sur  run.def  ****  '
+              STOP
+           ENDIF
+      ENDIF
+c
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de dzoomx passee par run.def est differente 
+     *  de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomyy = 0.0
+       CALL getin('dzoomy',dzoomyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        PRINT *,' La valeur de dzoomy passee par run.def est differente 
+     * de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+      
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       tauxx = 3.0
+       CALL getin('taux',tauxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de taux passee par run.def est differente
+     * de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = tauyy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauyy = 3.0
+       CALL getin('tauy',tauyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        PRINT *,' La valeur de tauy passee par run.def est differente
+     * de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+cc
+      IF( .NOT.fxyhypb  )  THEN
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinuss = .TRUE.
+       CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' *** ysinus lu sur le fichier start est F ',
+     *       'alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' ***  ysinus lu sur le fichier start est T ',
+     *        'alors  qu il est  F  sur  run.def  ****  '
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' idissip = ', idissip
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' clonn = ', clonn 
+      write(lunout,*)' clatt = ', clatt
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypbb = ', fxyhypbb
+      write(lunout,*)' dzoomxx = ', dzoomxx
+      write(lunout,*)' dzoomy = ', dzoomyy
+      write(lunout,*)' tauxx = ', tauxx
+      write(lunout,*)' tauyy = ', tauyy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' config_inca = ', config_inca
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      PRINT *,' alphax alphay defrun ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' idissip = ', idissip
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' clonn = ', clonn 
+      write(lunout,*)' clatt = ', clatt
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypbb = ', fxyhypbb
+      write(lunout,*)' dzoomx = ', dzoomx
+      write(lunout,*)' dzoomy = ', dzoomy
+      write(lunout,*)' taux = ', taux
+      write(lunout,*)' tauy = ', tauy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' config_inca = ', config_inca
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/conf_guide.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/conf_guide.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/conf_guide.F	(revision 984)
@@ -0,0 +1,51 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE conf_guide
+c
+      use IOIPSL
+      use getparam
+      IMPLICIT NONE
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+#include "guide.h"
+
+      call getpar('guide.eff')
+
+      call getpar('online',1,online,'Index de controle du guide')
+      CALL getpar('ncep',.false.,ncep,'Coordonnee vert NCEP ou ECMWF')
+      CALL getpar('ini_anal',.false.,ini_anal,'Initial = analyse')
+
+      CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+      CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+      CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+      CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+      CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+
+c   Constantes de rappel. Unite : fraction de jour
+      CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+      CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+      CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+      CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+      CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+      CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+      CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+      CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+      CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+      CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+
+c   Latitude min et max pour le rappel.
+c   dans le cas ou on 'a les analyses que sur une bande de latitudes.
+      CALL getpar('lat_min_guide',-90.,lat_min_guide
+     s     ,'Latitude minimum pour le guidage ')
+      CALL getpar('lat_max_guide', 90.,lat_max_guide
+     s     ,'Latitude maximum pour le guidage ')
+
+
+      CALL getpar
+
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/control.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/control.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/control.h	(revision 984)
@@ -0,0 +1,24 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'control.h'
+
+      COMMON/control/nday,day_step,                                     &
+     &              iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , &
+     &              periodav,iecrimoy,dayref,anneeref,                  &
+     &              raz_date,offline,ip_ebil_dyn,config_inca
+
+      INTEGER   nday,day_step,iperiod,iapp_tracvl,iconser,iecri,        &
+     &          idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date      &
+     &          ,ip_ebil_dyn
+      REAL periodav
+      logical offline
+      CHARACTER (len=4) :: config_inca
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/convflu.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/convflu.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/convflu.F	(revision 984)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+      SUBROUTINE convflu( xflu,yflu,nbniv,convfl )
+c
+c  P. Le Van
+c
+c
+c    *******************************************************************
+c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+c      composantes xflu et yflu ,variables extensives .  ......
+c    *******************************************************************
+c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+c      convfl                est  un argument de sortie pour le s-pg .
+c
+c     njxflu  est le nombre de lignes de latitude de xflu, 
+c     ( = jjm ou jjp1 )
+c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      REAL       xflu,yflu,convfl,convpn,convps
+      INTEGER    l,ij,nbniv
+      DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) ,
+     *         convfl( ip1jmp1,nbniv )
+c
+      REAL       SSUM
+c
+c
+#include "comgeom.h"
+c
+      DO 5 l = 1,nbniv
+c
+      DO 2  ij = iip2, ip1jm - 1
+      convfl( ij + 1,l ) =  xflu(   ij,l ) - xflu( ij +  1,l )   +
+     *                      yflu(ij +1,l ) - yflu( ij -iim,l )
+   2  CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+   3  CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+      DO 4 ij = 1,iip1
+      convfl(     ij   ,l ) = convpn * aire(   ij     ) / apoln
+      convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols
+   4  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/convmas.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/convmas.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/convmas.F	(revision 984)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      SUBROUTINE convmas (pbaru, pbarv, convm )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+
+       CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+
+      DO      l      = llmm1, 1, -1
+        DO    ij     = 1, ip1jmp1
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/coordij.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/coordij.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/coordij.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE coordij(lon,lat,ilon,jlat)
+
+c=======================================================================
+c
+c   calcul des coordonnees i et j de la maille scalaire dans
+c   laquelle se trouve le point (lon,lat) en radian
+c
+c=======================================================================
+
+      IMPLICIT NONE
+      REAL lon,lat
+      INTEGER ilon,jlat
+      INTEGER i,j
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+
+      real zlon,zlat
+
+      zlon=lon*pi/180.
+      zlat=lat*pi/180.
+
+      DO i=1,iim+1
+         IF (rlonu(i).GT.zlon) THEN
+            ilon=i
+            GOTO 10
+         ENDIF
+      ENDDO
+10    CONTINUE
+
+      j=0
+      DO j=1,jjm
+         IF(rlatv(j).LT.zlat) THEN
+            jlat=j
+            GOTO 20
+         ENDIF
+      ENDDO
+20    CONTINUE
+      IF(j.EQ.0) j=jjm+1
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/covcont.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/covcont.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/covcont.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. contravariantes a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO 10 l = 1,klevel
+
+      DO 2  ij = iip2, ip1jm
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = 1,ip1jm
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/covnat.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/covnat.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/covnat.F	(revision 984)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  F Hourdin Phu LeVan
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. naturelles a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO l = 1,klevel
+         DO ij = 1, iip1
+            unat (ij,l) =0.
+         END DO
+
+         DO ij = iip2, ip1jm
+            unat( ij,l ) = ucov( ij,l ) / cu(ij)
+         ENDDO
+         DO ij = ip1jm+1, ip1jmp1  
+            unat (ij,l) =0.
+         END DO
+
+         DO ij = 1,ip1jm
+            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+         ENDDO
+
+      ENDDO
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/cray.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/cray.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/cray.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/create_etat0_limit.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/create_etat0_limit.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/create_etat0_limit.F	(revision 984)
@@ -0,0 +1,71 @@
+!
+! $Header$
+!
+       PROGRAM create_etat0_limit
+       USE dimphy
+       USE comgeomphy
+
+c
+c
+c     Programme d'appel a etat0, creation des etats initiaux et limit_netcdf
+c   
+c
+c     interbar = .T . si appel a  interpol. barycentrique inter_barxy
+c
+c     extrap   = .T . si on fait une extrapolation de donnees , comme pour
+c       les  SST  lorsque  le fichier ne contient pas uniquement  des points 
+c     oceaniques .
+c
+c     oldice   = .T. si l'on veut garder les anciennes glaces , obtenues
+c     par  grille_m  ( grid_atob ) .
+c
+c     on cree le masque dans etat0 que l'on passe ensuite dans limit pour 
+c     garder les coherences
+
+      LOGICAL interbar, extrap , oldice
+      PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.)
+#include "dimensions.h"
+#include "paramet.h"
+#include "indicesol.h"
+#include "advtrac.h"
+#include  "control.h"
+      REAL :: masque(iip1,jjp1)
+      REAL :: pctsrf(iim*(jjm-1)+2, nbsrf)
+
+c initialisation traceurs
+      hadv_flg(:) = 0.
+      vadv_flg(:) = 0.
+      conv_flg(:) = 0.
+      pbl_flg(:)  = 0. 
+      tracnam(:)  = '        ' 
+      nprath = 1
+      nbtrac = 0
+      mmt_adj(:,:,:,:) = 1
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         call init_const_lmdz(nbtrac,anneeref,dayref,iphysiq,day_step,nday)
+#endif
+         print *, 'nbtrac =' , nbtrac 
+      END IF
+
+      CALL Init_Phys_lmdz(iim,jjp1,llm,nqmx-2,1,(jjm-1)*iim+2)
+      call InitComgeomphy
+
+      WRITE(6,*) '  *********************  '
+      WRITE(6,*) ' interbar = ',interbar
+      CALL etat0_netcdf ( interbar, masque, pctsrf )
+c
+      WRITE(6,1)
+      WRITE(6,*) '  *********************  '
+      WRITE(6,*) '  ***  Limit_netcdf ***  '
+      WRITE(6,*) '  *********************  '
+      WRITE(6,1)
+      
+c     
+      CALL  limit_netcdf ( interbar, extrap , oldice, masque, pctsrf )
+
+1     FORMAT(//)
+
+      STOP
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/defrun.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/defrun.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/defrun.F	(revision 984)
@@ -0,0 +1,495 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE defrun( tapedef, etatinit, clesphy0 )
+c
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "clesph0.h"
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      INTEGER   tapeout
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy,tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      tapeout = 6
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+      OPEN( tapedef,file ='gcm.def',status='old',form='formatted')
+
+
+      READ (tapedef,9000) ch1,ch2,ch3
+      WRITE(tapeout,9000) ch1,ch2,ch3
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dayref
+      WRITE(tapeout,9001) ch1,'dayref'
+      WRITE(tapeout,*)    dayref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    anneeref
+      WRITE(tapeout,9001) ch1,'anneeref'
+      WRITE(tapeout,*)    anneeref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nday
+      WRITE(tapeout,9001) ch1,'nday'
+      WRITE(tapeout,*)    nday
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    day_step
+      WRITE(tapeout,9001) ch1,'day_step'
+      WRITE(tapeout,*)    day_step
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iperiod
+      WRITE(tapeout,9001) ch1,'iperiod'
+      WRITE(tapeout,*)    iperiod
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iapp_tracvl
+      WRITE(tapeout,9001) ch1,'iapp_tracvl'
+      WRITE(tapeout,*)    iapp_tracvl
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iconser
+      WRITE(tapeout,9001) ch1,'iconser'
+      WRITE(tapeout,*)    iconser
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iecri
+      WRITE(tapeout,9001) ch1,'iecri'
+      WRITE(tapeout,*)    iecri
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    periodav
+      WRITE(tapeout,9001) ch1,'periodav'
+      WRITE(tapeout,*)    periodav
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    idissip
+      WRITE(tapeout,9001) ch1,'idissip'
+      WRITE(tapeout,*)    idissip
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    lstardis
+      WRITE(tapeout,9001) ch1,'lstardis'
+      WRITE(tapeout,*)    lstardis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergdiv
+      WRITE(tapeout,9001) ch1,'nitergdiv'
+      WRITE(tapeout,*)    nitergdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergrot
+      WRITE(tapeout,9001) ch1,'nitergrot'
+      WRITE(tapeout,*)    nitergrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    niterh
+      WRITE(tapeout,9001) ch1,'niterh'
+      WRITE(tapeout,*)    niterh
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagdiv
+      WRITE(tapeout,9001) ch1,'tetagdiv'
+      WRITE(tapeout,*)    tetagdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagrot
+      WRITE(tapeout,9001) ch1,'tetagrot'
+      WRITE(tapeout,*)    tetagrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetatemp
+      WRITE(tapeout,9001) ch1,'tetatemp'
+      WRITE(tapeout,*)    tetatemp
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    coefdis
+      WRITE(tapeout,9001) ch1,'coefdis'
+      WRITE(tapeout,*)    coefdis
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    purmats
+      WRITE(tapeout,9001) ch1,'purmats'
+      WRITE(tapeout,*)    purmats
+
+c    ...............................................................
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_phys
+      WRITE(tapeout,9001) ch1,'iflag_phys'
+      WRITE(tapeout,*)    iflag_phys
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iphysiq
+      WRITE(tapeout,9001) ch1,'iphysiq'
+      WRITE(tapeout,*)    iphysiq
+
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    cycle_diurne
+      WRITE(tapeout,9001) ch1,'cycle_diurne'
+      WRITE(tapeout,*)    cycle_diurne
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    soil_model
+      WRITE(tapeout,9001) ch1,'soil_model'
+      WRITE(tapeout,*)    soil_model
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    new_oliq
+      WRITE(tapeout,9001) ch1,'new_oliq'
+      WRITE(tapeout,*)    new_oliq
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orodr
+      WRITE(tapeout,9001) ch1,'ok_orodr'
+      WRITE(tapeout,*)    ok_orodr
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orolf
+      WRITE(tapeout,9001) ch1,'ok_orolf'
+      WRITE(tapeout,*)    ok_orolf
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_limitvrai
+      WRITE(tapeout,9001) ch1,'ok_limitvrai'
+      WRITE(tapeout,*)    ok_limitvrai
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nbapp_rad
+      WRITE(tapeout,9001) ch1,'nbapp_rad'
+      WRITE(tapeout,*)    nbapp_rad
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_con
+      WRITE(tapeout,9001) ch1,'iflag_con'
+      WRITE(tapeout,*)    iflag_con
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = FLOAT( iflag_con )
+                          clesphy0(2) = FLOAT( nbapp_rad )
+
+       IF( cycle_diurne  ) clesphy0(3) =  1.
+       IF(   soil_model  ) clesphy0(4) =  1.
+       IF(     new_oliq  ) clesphy0(5) =  1.
+       IF(     ok_orodr  ) clesphy0(6) =  1.
+       IF(     ok_orolf  ) clesphy0(7) =  1.
+       IF(  ok_limitvrai ) clesphy0(8) =  1.
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clonn
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clonn
+      IF( ABS(clon - clonn).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clatt
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clatt
+
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismxx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismxx
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismyy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismyy
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypbb
+      WRITE(tapeout,9001) ch1,'fxyhypbb'
+      WRITE(tapeout,*)    fxyhypbb
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F'
+     *,      '                   alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t'
+     *,      '                   alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomxx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomyy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomyy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauxx
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    tauxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauyy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauyy
+
+      IF( fxyhypb )  THEN
+
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de taux passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de tauy passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+      ENDIF
+      
+cc
+      IF( .NOT.fxyhypb  )  THEN
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ysinuss
+        WRITE(tapeout,9001) ch1,'ysinus'
+        WRITE(tapeout,*)    ysinuss
+
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est T',
+     *       ' alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+      WRITE(6,*) ' alphax alphay defrun ',alphax,alphay
+
+      CLOSE(tapedef)
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clon
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clon
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clat
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clat
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismy
+
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) '***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypb
+      WRITE(tapeout,9001) ch1,'fxyhypb'
+      WRITE(tapeout,*)    fxyhypb
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    taux
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    taux
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ysinus
+      WRITE(tapeout,9001) ch1,'ysinus'
+      WRITE(tapeout,*)    ysinus
+       
+      WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a12)
+cc
+      CLOSE(tapedef)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/description.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/description.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/description.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      character *120 descript
+      common /titre/descript
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/diagedyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/diagedyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/diagedyn.F	(revision 984)
@@ -0,0 +1,319 @@
+!
+! $Header$
+!
+
+C======================================================================
+      SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime
+     e  , ucov    , vcov , ps, p ,pk , teta , q, ql)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la dynamique.
+C
+C
+c======================================================================
+C Arguments: 
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+C uconv, vconv-input-R- vents covariants (m/s)
+C ps-------input-R- Surface pressure (Pa)
+C p--------input-R- pressure at the interfaces
+C pk-------input-R- pk= (p/Pref)**kappa
+c teta-----input-R- potential temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c aire-----input-R- mesh surafce (m2)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+#ifdef CPP_PHYS
+#include "../phylmd/YOMCST.h"
+#include "../phylmd/YOETHF.h"
+#endif
+C
+      INTEGER imjmp1
+      PARAMETER( imjmp1=iim*jjp1)
+c     Input variables
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )  ! pression aux interfac.des couches
+      REAL pk (ip1jmp1,llm  )  ! = (p/Pref)**kappa
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm)               ! champs eau vapeur
+      REAL ql(ip1jmp1,llm)               ! champs eau liquide
+
+
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL ecin(ip1jmp1,llm)
+
+      REAL zaire(imjmp1)
+      REAL zps(imjmp1)
+      REAL zairm(imjmp1,llm)
+      REAL zecin(imjmp1,llm)
+      REAL zpaprs(imjmp1,llm)
+      REAL zpk(imjmp1,llm)
+      REAL zt(imjmp1,llm)
+      REAL zh(imjmp1,llm)
+      REAL zqw(imjmp1,llm)
+      REAL zql(imjmp1,llm)
+      REAL zqs(imjmp1,llm)
+
+      REAL  zqw_col(imjmp1)
+      REAL  zql_col(imjmp1)
+      REAL  zqs_col(imjmp1)
+      REAL  zec_col(imjmp1)
+      REAL  zh_dair_col(imjmp1)
+      REAL  zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k, jj, ij , l ,ip1jjm1
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+
+
+#ifdef CPP_PHYS
+c======================================================================
+C     Compute Kinetic enrgy
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL massdair( p, masse )
+c======================================================================
+C
+C
+      print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?'
+      return
+C     On ne garde les donnees que dans les colonnes i=1,iim
+      DO jj = 1,jjp1
+        ip1jjm1=iip1*(jj-1)
+        DO ij =  1,iim
+          i=iim*(jj-1)+ij
+          zaire(i)=aire(ij+ip1jjm1)
+          zps(i)=ps(ij+ip1jjm1)
+        ENDDO 
+      ENDDO 
+C 3D arrays
+      DO l  =  1, llm
+        DO jj = 1,jjp1
+          ip1jjm1=iip1*(jj-1)
+          DO ij =  1,iim
+            i=iim*(jj-1)+ij
+            zairm(i,l) = masse(ij+ip1jjm1,l)
+            zecin(i,l) = ecin(ij+ip1jjm1,l)
+            zpaprs(i,l) = p(ij+ip1jjm1,l)
+            zpk(i,l) = pk(ij+ip1jjm1,l)
+            zh(i,l) = teta(ij+ip1jjm1,l)
+            zqw(i,l) = q(ij+ip1jjm1,l)
+            zql(i,l) = ql(ij+ip1jjm1,l)
+            zqs(i,l) = 0.
+          ENDDO 
+        ENDDO 
+      ENDDO 
+C
+C     Reset variables
+      DO i = 1, imjmp1
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, llm
+        DO i = 1, imjmp1
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +zecin(i,k)*zairm(i,k)
+C         Air enthalpy
+          zt(i,k)= zh(i,k) * zpk(i,k) / RCPD
+          zh_dair_col(i) = zh_dair_col(i)
+     $        + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLVTT*zql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLSTT*zqs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,imjmp1
+        qw_tot = qw_tot + zqw_col(i)
+        ql_tot = ql_tot + zql_col(i)
+        qs_tot = qs_tot + zqs_col(i)
+        ec_tot = ec_tot + zec_col(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)
+        airetot=airetot+zaire(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+C        WRITE(6,9003) tit,pas(idiag), ec_tot
+ 9003   format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6))
+        WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec
+ 9004   format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+#else
+      print*,'Pour l instant diagedyn a besoin de la physique'
+#endif
+      RETURN 
+      END 
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dissip.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dissip.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dissip.F	(revision 984)
@@ -0,0 +1,143 @@
+!
+! $Header$
+!
+      SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh )
+c
+      IMPLICIT NONE
+
+
+c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+c                                 (  10/01/98  )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation horizontale
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comdissnew.h"
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL  p( ip1jmp1,llmp1 )
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
+      REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
+      REAL te1dt(llm),te2dt(llm),te3dt(llm)
+      REAL deltapres(ip1jmp1,llm)
+
+      INTEGER l,ij
+
+      REAL  SSUM
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      DO l=1,llm
+         te1dt(l) = tetaudiv(l) * dtdiss
+         te2dt(l) = tetaurot(l) * dtdiss
+         te3dt(l) = tetah(l)    * dtdiss
+      ENDDO
+      du=0.
+      dv=0.
+      dh=0.
+
+c-----------------------------------------------------------------------
+c   Calcul de la dissipation:
+c   -------------------------
+
+c   Calcul de la partie   grad  ( div ) :
+c   -------------------------------------
+
+
+      IF(lstardis) THEN
+         CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+         CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ENDIF
+
+      DO l=1,llm
+
+         DO ij = 1, iip1
+            gdx(     ij ,l) = 0.
+            gdx(ij+ip1jm,l) = 0.
+         ENDDO
+
+         DO ij = iip2,ip1jm
+            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+         ENDDO
+
+       ENDDO
+
+c   calcul de la partie   n X grad ( rot ):
+c   ---------------------------------------
+
+      IF(lstardis) THEN
+         CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+         CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry )
+      ENDIF
+
+
+      DO l=1,llm
+         DO ij = 1, iip1
+            grx(ij,l) = 0.
+         ENDDO
+
+         DO ij = iip2,ip1jm
+            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+         ENDDO
+         DO ij =  1, ip1jm
+            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+         ENDDO
+      ENDDO
+
+c   calcul de la partie   div ( grad ):
+c   -----------------------------------
+
+        
+      IF(lstardis) THEN
+
+       DO l = 1, llm
+          DO ij = 1, ip1jmp1
+            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+          ENDDO
+       ENDDO
+
+         CALL divgrad2( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+         CALL divgrad ( llm,teta, niterh, gdx        )
+      ENDIF
+
+      DO l = 1,llm
+         DO ij = 1,ip1jmp1
+            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/disvert.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/disvert.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/disvert.F	(revision 984)
@@ -0,0 +1,170 @@
+!
+! $Header$
+!
+      SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL pa,preff
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+       real zzz(1:llm+1)
+       real dzz(1:llm)
+      real zk,zkm1,dzk1,dzk2,k0,k1
+c
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) h           ! hauteur d'echelle 8.
+      READ(99,*) deltaz      ! epaiseur de la premiere couche 0.04
+      READ(99,*) beta        ! facteur d'acroissement en haut 1.3
+      READ(99,*) k0          ! nombre de couches dans la transition surf
+      READ(99,*) k1          ! nombre de couches dans la transition haute
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+      write(lunout,*)'h,alpha,k0,k1,beta'
+
+c     read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2
+
+      alpha=deltaz/tanh(1./k0)*2.
+      zkm1=0.
+      sig(1)=1.
+      do l=1,llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/h)
+     + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta))
+        zk=-h*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        write(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2
+        zkm1=zk
+      enddo
+
+      sig(llm+1)=0.
+
+c
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      WRITE(LUNOUT,*)'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
+
+c
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c
+c   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+c
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+cc
+ccc    ap(l) = 0.
+ccc    bp(l) = sig(l)
+
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+c
+      ENDDO
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      write(lunout,*)' BP '
+      write(lunout,*)  bp
+      write(lunout,*)' AP '
+      write(lunout,*)  ap
+
+      write(lunout,*)
+     .'Niveaux de pressions approximatifs aux centres des'
+      write(lunout,*)'couches calcules pour une pression de surface =',
+     .                 preff
+      write(lunout,*)
+     .     'et altitudes equivalentes pour une hauteur d echelle de'
+      write(lunout,*)'8km'
+      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 )
+       write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),'    Z ~ ',
+     .        log(preff/presnivs(l))*8.
+     .  ,'   DZ ~ ',8.*log((ap(l)+bp(l)*preff)/
+     .       max(ap(l+1)+bp(l+1)*preff,1.e-10))
+      ENDDO
+
+      write(lunout,*)' PRESNIVS '
+      write(lunout,*)presnivs
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/disvert0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/disvert0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/disvert0.F	(revision 984)
@@ -0,0 +1,175 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL pa,preff,presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+       real zzz(1:llm+1)
+       real dzz(1:llm)
+      real zk,zkm1,dzk1,dzk2,k0,k1
+c
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+
+      pa        =  50 000.
+      preff     = 101 325.
+
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) h           ! hauteur d'echelle 8.
+      READ(99,*) deltaz      ! epaiseur de la premiere couche 0.04
+      READ(99,*) beta        ! facteur d'acroissement en haut 1.3
+      READ(99,*) k0          ! nombre de couches dans la transition surf
+      READ(99,*) k1          ! nombre de couches dans la transition haute
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+      WRITE(lunout,*)'h,alpha,k0,k1,beta'
+
+c     read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2
+
+      alpha=deltaz/tanh(1./k0)*2.
+      zkm1=0.
+      sig(1)=1.
+      do l=1,llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/h)
+     + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta))
+        zk=-h*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        WRITE(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2
+        zkm1=zk
+      enddo
+
+      sig(llm+1)=0.
+
+c
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      write(lunout,*)'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
+
+c
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c
+c   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+c
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+cc
+ccc    ap(l) = 0.
+ccc    bp(l) = sig(l)
+
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+c
+      ENDDO
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      write(lunout,*)' BP '
+      write(lunout,*)  bp
+      write(lunout,*)' AP '
+      write(lunout,*)  ap
+
+      write(lunout,*)
+     .'Niveaux de pressions approximatifs aux centres des'
+      write(lunout,*)
+     .'couches calcules pour une pression de surface =',preff
+      write(lunout,*)
+     .'et altitudes equivalentes pour une hauteur d echelle de'
+      write(lunout,*)'8km'
+      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 )
+       write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),'    Z ~ ',
+     .        log(preff/presnivs(l))*8.
+     .  ,'   DZ ~ ',8.*log((ap(l)+bp(l)*preff)/
+     .       max(ap(l+1)+bp(l+1)*preff,1.e-10))
+      ENDDO
+
+      write(lunout,*)' PRESNIVS '
+      write(lunout,*)presnivs
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/diverg.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/diverg.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/diverg.F	(revision 984)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE diverg(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/diverg_gam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/diverg_gam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/diverg_gam.F	(revision 984)
@@ -0,0 +1,80 @@
+!
+! $Header$
+!
+      SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam ,
+     *                       unsapolnga,unsapolsga,  x, y,  div )
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+      REAL unsapolnga,unsapolsga
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+      INTEGER   l,ij
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     = (  
+     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
+     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
+     *         unsairegam( ij+1 )
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+        sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn 
+         div( ij + ip1jm, l ) =   sumyps 
+        ENDDO
+  10  CONTINUE
+c
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/divergf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/divergf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/divergf.F	(revision 984)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE divergf(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/divergst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/divergst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/divergst.F	(revision 984)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+      SUBROUTINE divergst(klevel,x,y,div)
+      IMPLICIT NONE
+c
+c     P. Le Van
+c
+c  ******************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y...
+c           x et y  etant des composantes contravariantes   ...
+c  ****************************************************************
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   -------------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER ij,l,i
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+
+      REAL SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1 ij = iip2, ip1jm - 1
+      div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
+   1  CONTINUE
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      div( ij,l ) = div( ij + iim,l )
+   3  CONTINUE
+c
+c     ....  calcul  aux poles  .....
+c
+c
+      DO 5 i  = 1,iim
+      aiy1(i)= y(i,l)
+      aiy2(i)= y(i+ip1jmi1,l)
+   5  CONTINUE
+      sumypn = SSUM ( iim,aiy1,1 )
+      sumyps = SSUM ( iim,aiy2,1 )
+      DO 7 i = 1,iip1
+      div(     i    , l ) = - sumypn/iim
+      div( i + ip1jm, l ) =   sumyps/iim
+   7  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/divgrad.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/divgrad.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/divgrad.F	(revision 984)
@@ -0,0 +1,56 @@
+!
+! $Header$
+!
+      SUBROUTINE divgrad (klevel,h, lh, divgra )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c  Auteur :   P. Le Van
+c  ----------
+c
+c                              lh
+c      calcul de  (div( grad ))   de h  .....
+c      h  et lh  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+c
+      DO 10 iter = 1,lh
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1  )
+
+      CALL    grad (klevel,divgra, ghx  , ghy          )
+      CALL  diverg (klevel,  ghx , ghy  , divgra       )
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1)
+
+      DO 5 l = 1,klevel
+      DO 4  ij = 1, ip1jmp1
+      divgra( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/divgrad2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/divgrad2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/divgrad2.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
+c
+c     P. Le Van
+c
+c   ***************************************************************
+c
+c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
+c   ****************************************************************
+c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+c         divgra     est  un argument  de sortie pour le s-prg
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comdissipn.h"
+
+c    .......    variables en arguments   .......
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+      REAL divgra( ip1jmp1,klevel)
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+
+c
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+
+c
+      CALL laplacien( klevel, divgra, divgra )
+     
+      DO l = 1, klevel
+       DO ij = 1, ip1jmp1
+        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+       ENDDO
+      ENDDO
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+   
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+       CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
+     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
+      ENDDO
+c
+c    ...............................................................
+ 
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c
+      CALL laplacien ( klevel, divgra, divgra )
+c
+      DO l  = 1,klevel
+      DO ij = 1,ip1jmp1
+      divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dteta1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dteta1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dteta1.F	(revision 984)
@@ -0,0 +1,68 @@
+!
+! $Header$
+!
+      SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+c
+c   ********************************************************************
+c   ... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dteta 	          sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dteta( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
+
+c
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm - 1
+      hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) )
+   1  CONTINUE
+
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+CDIR$ IVDEP
+      DO 2 ij = iip1+ iip1, ip1jm, iip1
+      hbxu( ij, l ) = hbxu( ij - iim, l )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+        CALL  convflu ( hbxu, hbyv, llm, dteta )
+
+
+c    stockage dans  dh de la convergence horizont. filtree' du  flux
+c                  ....                           ...........
+c           d'enthalpie potentielle .
+
+      CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1)
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dudv1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dudv1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dudv1.F	(revision 984)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv )
+      IMPLICIT NONE
+c
+c-----------------------------------------------------------------------
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c   calcul du terme de  rotation
+c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
+c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
+c   du  et dv              sont des arguments de sortie pour le s-pg ..
+c
+c-----------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) ,
+     *     pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm )
+      INTEGER  l,ij
+c
+c
+      DO 10 l = 1,llm
+c
+      DO 2  ij = iip2, ip1jm - 1
+      du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) *
+     *                    (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) +
+     *                        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
+   2  CONTINUE
+c
+      DO 3 ij = 1, ip1jm - 1
+      dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) *
+     *                        (   pbaru(ij, l)  +  pbaru(ij+1   , l) +
+     *                       pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
+   3  CONTINUE
+c
+c    .... correction  pour  dv( 1,j,l )  .....
+c    ....   dv(1,j,l)= dv(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 4 ij = 1, ip1jm, iip1
+      dv( ij,l ) = dv( ij + iim, l )
+   4  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dudv2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dudv2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dudv2.F	(revision 984)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      SUBROUTINE dudv2 ( teta, pkf, bern, du, dv  )
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *****************************************************************
+c   ..... calcul du terme de pression (gradient de p/densite )   et
+c          du terme de ( -gradient de la fonction de Bernouilli ) ...
+c   *****************************************************************
+c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+c
+c
+c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+c    du et dv          sont des arguments de sortie pour le s-pg  ....
+c
+c=======================================================================
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ),
+     *         du( ip1jmp1,llm ),  dv( ip1jm,llm )
+      INTEGER  l,ij
+c
+c
+      DO 5 l = 1,llm
+c
+      DO 2  ij  = iip2, ip1jm - 1
+       du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) *
+     * ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
+   2  CONTINUE
+c
+c
+c    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
+c    ...          du(iip1,j,l) = du(1,j,l)                 ...
+c
+CDIR$ IVDEP
+      DO 3 ij = iip1+ iip1, ip1jm, iip1
+      du( ij,l ) = du( ij - iim,l )
+   3  CONTINUE
+c
+c
+      DO 4 ij  = 1,ip1jm
+      dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) *
+     *                             ( pkf(ij+iip1,l) - pkf(  ij,l  ) )
+     *                           +   bern( ij+iip1,l ) - bern( ij  ,l )
+   4  CONTINUE
+c
+   5  CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dump2d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dump2d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dump2d.F	(revision 984)
@@ -0,0 +1,46 @@
+!
+! $Header$
+!
+      SUBROUTINE dump2d(im,jm,z,nom_z)
+      IMPLICIT NONE
+      INTEGER im,jm
+      REAL z(im,jm)
+      CHARACTER*80 nom_z
+
+      INTEGER i,j,imin,illm,jmin,jllm
+      REAL zmin,zllm
+
+      PRINT*,nom_z
+
+      zmin=z(1,1)
+      zllm=z(1,1)
+      imin=1
+      illm=1
+      jmin=1
+      jllm=1
+
+      DO j=1,jm
+         DO i=1,im
+            IF(z(i,j).GT.zllm) THEN
+               illm=i
+               jllm=j
+               zllm=z(i,j)
+            ENDIF
+            IF(z(i,j).LT.zmin) THEN
+               imin=i
+               jmin=j
+               zmin=z(i,j)
+            ENDIF
+         ENDDO
+      ENDDO
+
+      PRINT*,'MIN: ',zmin
+      PRINT*,'MAX: ',zllm
+
+      IF(zllm.GT.zmin) THEN
+      DO j=1,jm
+      WRITE(*,'(72i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
+      ENDDO
+      ENDIF
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dynetat0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dynetat0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dynetat0.F	(revision 984)
@@ -0,0 +1,383 @@
+!
+! $Header$
+!
+      SUBROUTINE dynetat0(fichnom,nq,vcov,ucov,
+     .                    teta,q,masse,ps,phis,time)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / L.Fairhead
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Lecture de l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "logic.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+
+      CHARACTER*(*) fichnom
+      INTEGER nq
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+
+      REAL time
+
+c   Variables 
+c
+      INTEGER length,iq
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid
+
+c-----------------------------------------------------------------------
+
+c  Ouverture NetCDF du fichier etat initial
+
+      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier start.nc'
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+
+      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)
+c
+      clon       = tab_cntrl(20)
+      clat       = tab_cntrl(21)
+      grossismx  = tab_cntrl(22)
+      grossismy  = tab_cntrl(23)
+c
+      IF ( tab_cntrl(24).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+c        dzoomx   = tab_cntrl(25)
+c        dzoomy   = tab_cntrl(26)
+c        taux     = tab_cntrl(28)
+c        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)
+c   .................................................................
+c
+c
+      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+      IF(   im.ne.iim           )  THEN
+          PRINT 1,im,iim
+          STOP
+      ELSE  IF( jm.ne.jjm       )  THEN
+          PRINT 2,jm,jjm
+          STOP
+      ELSE  IF( lllm.ne.llm     )  THEN
+          PRINT 3,lllm,llm
+          STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour rlatv"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "aire", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <aire> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <aire>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phis)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <temps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, time)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee <temps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ucov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ucov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ucov>"
+         CALL abort
+      ENDIF
+ 
+      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <vcov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, vcov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <vcov>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <teta> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, teta)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <teta>"
+         CALL abort
+      ENDIF
+
+
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+        ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent"
+           PRINT*, "          Il est donc initialise a zero"
+           q(:,:,iq)=0.
+        ELSE
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq))
+#endif
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "dynetat0: Lecture echouee pour "//tname(iq)
+             CALL abort
+          ENDIF
+        ENDIF
+      ENDDO
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <masse> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, masse)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <masse>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ps)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_CLOSE(nid)
+
+       day_ini=day_ini+INT(time)
+       time=time-INT(time)
+
+  1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur  dtinteg =',i4//)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/dynredem.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/dynredem.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/dynredem.F	(revision 984)
@@ -0,0 +1,734 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE dynredem0(fichnom,iday_end,phis,nq)
+      USE IOIPSL
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#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 "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(ip1jmp1)
+      CHARACTER*(*) fichnom
+      INTEGER nq
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+
+c-----------------------------------------------------------------------
+      modname='dynredem'
+
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+        
+
+      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
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      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
+
+       tab_cntrl(30) = FLOAT(iday_end)
+       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+      ENDIF
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      RETURN
+      END
+      SUBROUTINE dynredem1(fichnom,time,
+     .                     vcov,ucov,teta,q,nq,masse,ps)
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "advtrac.h"
+#include "temps.h"
+#include "control.h"
+
+      INTEGER nq, l
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL q(ip1jmp1,llm,nq)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid, nid_trac, nvarid_trac
+      REAL trac_tmp(ip1jmp1,llm)      
+      INTEGER ierr, ierr_file 
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      modname = 'dynredem1'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable temps n est pas definie'
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
+#endif
+
+      IF (config_inca /= 'none') THEN
+! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc
+         ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac)
+         IF (ierr_file .NE.NF_NOERR) THEN
+            write(6,*)' Pb d''ouverture du fichier start_trac.nc'
+            write(6,*)' ierr = ', ierr_file 
+         ENDIF
+      END IF
+
+      IF(nq.GE.1) THEN
+      do iq=1,nq 
+
+         IF (config_inca == 'none') THEN
+            ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+            IF (ierr .NE. NF_NOERR) THEN
+               PRINT*, "Variable  tname(iq) n est pas definie"
+               CALL abort
+            ENDIF
+#ifdef NC_DOUBLE
+            ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+            ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+        ELSE ! config_inca = 'chem' ou 'aero'
+! lecture de la valeur du traceur dans start_trac.nc
+           IF (ierr_file .ne. 2) THEN
+             ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, tname(iq),"est absent de start_trac.nc"
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+#ifdef NC_DOUBLE
+                ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+                ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+                
+             ELSE
+                PRINT*, tname(iq), "est present dans start_trac.nc"
+#ifdef NC_DOUBLE
+               ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp)
+#else
+               ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp)
+#endif
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Lecture echouee pour", tname(iq)
+                   CALL abort
+                ENDIF
+                ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+                IF (ierr .NE. NF_NOERR) THEN
+                   PRINT*, "Variable ", tname(iq)," n est pas definie"
+                   CALL abort
+                ENDIF
+#ifdef NC_DOUBLE
+                ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp)
+#else
+                ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp)
+#endif
+               
+             ENDIF ! IF (ierr .NE. NF_NOERR)
+! fin lecture du traceur
+          ELSE                  ! si il n'y a pas de fichier start_trac.nc
+!             print *, 'il n y a pas de fichier start_trac'
+             ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+             IF (ierr .NE. NF_NOERR) THEN
+                PRINT*, "Variable  tname(iq) n est pas definie"
+                CALL abort
+             ENDIF
+#ifdef NC_DOUBLE
+             ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+             ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+          ENDIF ! (ierr_file .ne. 2)
+       END IF   ! config_inca
+      
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
+#endif
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ener.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ener.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ener.h	(revision 984)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'ener.h'
+
+      COMMON/ener/ang0,etot0,ptot0,ztot0,stot0,
+     *            ang,etot,ptot,ztot,stot,rmsdpdt ,
+     *            rmsv,gtot(llmm1)
+
+      REAL ang0,etot0,ptot0,ztot0,stot0,
+     s     ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/enercin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/enercin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/enercin.F	(revision 984)
@@ -0,0 +1,98 @@
+!
+! $Header$
+!
+      SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i
+
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = iip2, ip1jm, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+
+      DO 3 i = 1, iim
+      ecinni(i) = vcov(    i  ,  l) * vcont(    i    ,l) * aire(   i   )
+      ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+   3  CONTINUE
+
+      ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+      ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+      DO 4 ij = 1,iip1
+      ecin(   ij     , l ) = ecinpn
+      ecin( ij+ ip1jm, l ) = ecinps
+   4  CONTINUE
+
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/etat0_netcdf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/etat0_netcdf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/etat0_netcdf.F	(revision 984)
@@ -0,0 +1,725 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE etat0_netcdf (interbar, masque, pctsrf)
+    
+      USE startvar
+      USE ioipsl
+      USE dimphy
+      USE fonte_neige_mod
+      USE pbl_surface_mod
+      USE ocean_slab_mod
+      USE surface_data
+      !
+      IMPLICIT NONE
+      !
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+      !
+      !
+!      INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, 
+!     .KLON=KFDIA-KIDIA+1,KLEV=llm
+      !
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "temps.h"
+      !
+      LOGICAL interbar
+      REAL :: latfi(klon), lonfi(klon)
+      REAL :: orog(iip1,jjp1), rugo(iip1,jjp1), masque(iip1,jjp1),
+     . psol(iip1, jjp1), phis(iip1, jjp1)
+      REAL :: p3d(iip1, jjp1, llm+1)
+      REAL :: uvent(iip1, jjp1, llm)
+      REAL :: vvent(iip1, jjm, llm)
+      REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm)
+      REAL :: q3d(iip1, jjp1, llm,nqmx), qsat(iip1, jjp1, llm)
+      REAL :: tsol(klon), qsol(klon), sn(klon)
+      REAL :: tsolsrf(klon,nbsrf), qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) 
+      REAL :: albe(klon,nbsrf), evap(klon,nbsrf)
+      REAL :: alblw(klon,nbsrf)
+      REAL :: tsoil(klon,nsoilmx,nbsrf) 
+      REAL :: radsol(klon),rain_fall(klon), snow_fall(klon)
+      REAL :: solsw(klon), sollw(klon), fder(klon)
+cIM "slab" ocean
+      REAL :: tslab(klon), seaice(klon)
+      REAL :: frugs(klon,nbsrf), agesno(klon,nbsrf)
+      REAL :: rugmer(klon)
+      REAL :: zmea(iip1*jjp1), zstd(iip1*jjp1)
+      REAL :: zsig(iip1*jjp1), zgam(iip1*jjp1), zthe(iip1*jjp1)
+      REAL :: zpic(iip1*jjp1), zval(iip1*jjp1), rugsrel(iip1*jjp1)
+      REAL :: qd(iip1, jjp1, llm)
+      REAL :: pctsrf(klon, nbsrf)
+      REAL :: t_ancien(klon,klev), q_ancien(klon,klev)      !
+      REAL :: run_off_lic_0(klon)
+      real :: clwcon(klon,klev),rnebcon(klon,klev),ratqs(klon,klev)
+      ! declarations pour lecture glace de mer
+      REAL :: rugv(klon)
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+      REAL :: champint(iim, jjp1)
+      !
+
+      CHARACTER*80 :: varname
+      !
+      INTEGER :: i,j, ig, l, ji,ii1,ii2
+      INTEGER :: nq
+      REAL :: xpi
+      !
+      REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm)
+      REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1)
+      REAL :: workvar(iip1,jjp1,llm)
+      !
+      REAL ::  prefkap, unskap
+      !
+      real :: time_step,t_ops,t_wrt
+
+#include "comdissnew.h"
+#include "control.h"
+#include "serre.h"
+#include "clesphys.h"
+
+      INTEGER  ::        longcles
+      PARAMETER      ( longcles  = 20 )
+      REAL :: clesphy0 ( longcles       )
+      REAL :: p(iip1,jjp1,llm)
+      INTEGER :: itau, iday
+      REAL :: masse(iip1,jjp1,llm)
+      REAL :: xpn,xps,xppn(iim),xpps(iim)
+      real :: time
+      REAL :: phi(ip1jmp1,llm)
+      REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL :: w(ip1jmp1,llm)
+      REAL ::phystep
+      INTEGER :: radpas
+       real zrel(iip1*jjp1),chmin,chmax
+
+      CHARACTER*80 :: visu_file
+      INTEGER :: visuid
+
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+      integer :: isst(klon-2)
+      real zx_tmp_2d(iim,jjp1)
+
+      REAL, DIMENSION(klon,klev,nbsrf) :: pbl_tke ! turb kinetic energy
+      REAL, DIMENSION(klon) :: zmax0, f0 
+      REAL, DIMENSION(klon,klev) :: ema_work1, ema_work2
+      REAL :: dummy(klon, nbsrf)
+      !
+      !   Constantes 
+      !
+      pi     = 4. * ATAN(1.)
+      rad    = 6371229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      !
+      preff     = 101325.
+      unskap = 1./kappa
+      !
+      jmp1    = jjm + 1
+      !
+      !    Construct a grid
+      !
+
+!      CALL defrun_new(99,.TRUE.,clesphy0)
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+      dtvr   = daysec/FLOAT(day_step)
+      print*,'dtvr',dtvr
+
+      CALL inicons0()
+      CALL inigeom()
+      !
+      CALL inifilr()
+      !
+      latfi(1) = ASIN(1.0)
+      DO j = 2, jjm
+        DO i = 1, iim
+          latfi((j-2)*iim+1+i)=  rlatu(j)
+        ENDDO
+      ENDDO
+      latfi(klon) = - ASIN(1.0)
+      !
+      lonfi(1) = 0.0
+      DO j = 2, jjm
+        DO i = 1, iim
+          lonfi((j-2)*iim+1+i) =  rlonv(i)
+        ENDDO
+      ENDDO
+      lonfi(klon) = 0.0
+      !
+      xpi = 2.0 * ASIN(1.0)
+      DO ig = 1, klon
+        latfi(ig) = latfi(ig) * 180.0 / xpi
+        lonfi(ig) = lonfi(ig) * 180.0 / xpi
+      ENDDO
+      !
+
+
+C
+C En cas de simulation couplee, lecture du masque ocean issu du modele ocean
+C utilise pour calculer les poids et pour assurer l'adequation entre les
+C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque 
+C a partir du fichier relief
+C
+
+      write(*,*)'Essai de lecture masque ocean'
+      iret = nf_open("o2a.nc", NF_NOWRITE, nid_o2a)
+      if (iret .ne. 0) then
+        write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve'
+        write(*,*)'Run force'
+        varname = 'masque'
+        masque(:,:) = 0.0
+        CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0,
+     ,  jjm ,rlonu,rlatv , interbar )
+        WRITE(*,*) 'MASQUE construit : Masque'
+        WRITE(*,'(97I1)') nINT(masque(:,:))
+        call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq)
+        WHERE (zmasq(1 : klon) .LT. EPSFRA)
+            zmasq(1 : klon) = 0.
+        END WHERE 
+        WHERE (1. - zmasq(1 : klon) .LT. EPSFRA)
+            zmasq(1 : klon) = 1.
+        END WHERE 
+      else
+        couple = .true.
+        iret = nf_close(nid_o2a)
+        call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp
+     $    , nid_o2a)
+        if (iml_omask /= iim .or. jml_omask /= jjp1) then
+          write(*,*)'Dimensions non compatibles pour masque ocean'
+          write(*,*)'iim = ',iim,' iml_omask = ',iml_omask
+          write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask
+          stop
+        endif
+        ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(dlon_omask(iml_omask), stat=iret)
+        ALLOCATE(dlat_omask(jml_omask), stat=iret)
+        ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret)
+        CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp
+     $    , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid)
+        CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, 
+     $      ttm_tmp, 1, 1, ocetmp)
+        CALL flinclo(fid)
+        dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1)
+        dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask)
+        ocemask = ocetmp
+        if (dlat_omask(1) < dlat_omask(jml_omask)) then
+          do j = 1, jml_omask
+            ocemask(:,j) = ocetmp(:,jml_omask-j+1)
+          enddo
+        endif 
+C
+C passage masque ocean a la grille physique
+C
+        write(*,*)'ocemask '
+        write(*,'(96i1)')int(ocemask)
+        ocemask_fi(1) = ocemask(1,1)
+        do j = 2, jjm
+          do i = 1, iim
+            ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j)
+          enddo
+        enddo
+        ocemask_fi(klon) = ocemask(1,jjp1)
+        zmasq = 1. - ocemask_fi
+      endif
+
+      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+
+      varname = 'relief'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      orog(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, orog, 0.0 ,
+     , jjm ,rlonu,rlatv , interbar, masque )
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Relief'
+!      WRITE(*,'(49I1)') INT(orog(:,:))
+      !
+      varname = 'rugosite'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      rugo(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, rugo, 0.0 ,
+     , jjm, rlonu,rlatv , interbar )
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' 
+!      WRITE(*,'(49I1)') INT(rugo(:,:)*10)
+      !
+C
+C on initialise les sous surfaces
+C
+      pctsrf=0.
+c
+      varname = 'psol'
+      psol(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, psol, 0.0 ,
+     , jjm ,rlonu,rlatv , interbar )
+      !
+      !  Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM 
+      !  anyway.
+      !
+!      WRITE(*,*) 'PSOL :', psol(10,20)
+!      WRITE(*,*) ap(:), bp(:)
+      CALL pression(ip1jmp1, ap, bp, psol, p3d)
+!      WRITE(*,*) 'P3D :', p3d(10,20,:)
+      CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar)
+!      WRITE(*,*) 'PK:', pk(10,20,:)
+      !
+      !
+      !
+      prefkap =  preff  ** kappa
+!      WRITE(*,*) 'unskap, cpp,  preff :', unskap, cpp,  preff
+      DO l = 1, llm
+        DO j=1,jjp1
+          DO i =1, iip1
+            pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+           ENDDO
+        ENDDO
+      ENDDO
+      !
+!      WRITE(*,*) 'PLS :', pls(10,20,:)
+      !
+      varname = 'surfgeo'
+      phis(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, phis, 0.0 ,
+     , jjm ,rlonu,rlatv, interbar )
+      !
+      varname = 'u'
+      uvent(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonu, rlatu, llm, pls,
+     . workvar, uvent, 0.0, jjm ,rlonv, rlatv, interbar )
+      !  
+      varname = 'v'
+      vvent(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjm, rlonv, rlatv, llm, pls,
+     . workvar, vvent, 0.0, jjp1, rlonu, rlatu, interbar )
+      !
+      varname = 't'
+      t3d(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . workvar, t3d, 0.0 , jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)),
+     .                          maxval(t3d(:,:,:))
+      varname = 'tpot'
+      tpot(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . pk, tpot, 0.0 , jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)),
+     .                          maxval(t3d(:,:,:))
+      WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)),
+     .                          maxval(pls(:,:,:))
+
+c Calcul de l'humidite a saturation
+      print*,'avant q_sat'
+      call q_sat(llm*jjp1*iip1,t3d,pls,qsat)
+      print*,'apres q_sat'
+
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      !
+      WRITE(*,*) 'QSAT :', qsat(10,20,:)
+      !
+      varname = 'q'
+      qd(:,:,:) = 0.0
+      q3d(:,:,:,:) = 0.0
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . qsat, qd, 0.0, jjm, rlonu, rlatv , interbar )
+      q3d(:,:,:,1) = qd(:,:,:)
+      !
+      varname = 'tsol'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      tsol(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol, 0.0,
+     .    jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'TSOL construit :'
+!      WRITE(*,'(48I3)') INT(TSOL(2:klon)-273)
+      !
+      varname = 'qsol'
+      qsol(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol, 0.0,
+     .   jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'snow'
+      sn(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0,
+     .    jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'rads'
+      radsol(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0,
+     .    jjm, rlonu, rlatv , interbar )
+      !
+cIM "slab" ocean
+      varname = 'tslab'
+      tslab(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,tslab,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+c
+      varname = 'seaice'
+      seaice(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,seaice,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'rugmer'
+      rugmer(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      !
+!      varname = 'agesno'
+!      agesno(:) = 0.0
+!      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0,
+!     .     jjm, rlonu, rlatv , interbar )
+
+      varname = 'zmea'
+      zmea(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+
+      varname = 'zstd'
+      zstd(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zsig'
+      zsig(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zgam'
+      zgam(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zthe'
+      zthe(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zpic'
+      zpic(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zval'
+      zval(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+c
+      rugsrel(:) = 0.0
+      IF(ok_orodr)  THEN
+        DO i = 1, iip1* jjp1
+         rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. )
+        ENDDO
+      ENDIF
+
+
+C
+C lecture du fichier glace de terre pour fixer la fraction de terre 
+C et de glace de terre
+C
+      CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp
+     $    , fid)
+      ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(dlon_lic(iml_lic), stat=iret)
+      ALLOCATE(dlat_lic(jml_lic), stat=iret)
+      ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret)
+      CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp
+     $    , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid)
+      CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp
+     $    , 1, 1, fraclic)
+      CALL flinclo(fid)
+C
+C interpolation sur la grille T du modele
+C
+      WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', 
+     $    iml_lic, jml_lic
+c
+C sil les coordonnees sont en degres, on les transforme
+C
+      IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) )  THEN
+          lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180.
+      ENDIF 
+      IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN 
+          lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180.
+      ENDIF 
+
+      dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1)
+      dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) 
+C
+      CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic
+     $    ,iim, jjp1,
+     $    rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1))
+cx$$$      flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1)
+      flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1)
+C
+C passage sur la grille physique
+C
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp,
+     $    pctsrf(1:klon, is_lic))
+C adequation avec le maque terre/mer
+c      zmasq(157) = 0.
+      WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) 
+          pctsrf(1 : klon, is_lic) = 0. 
+      END WHERE
+      WHERE (zmasq( 1 : klon) .LT. EPSFRA) 
+          pctsrf(1 : klon, is_lic) = 0.
+      END WHERE 
+      pctsrf(1 : klon, is_ter) = zmasq(1 : klon)
+      DO ji = 1, klon
+        IF (zmasq(ji) .GT. EPSFRA) THEN 
+            IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN
+                pctsrf(ji, is_lic) = zmasq(ji)
+                pctsrf(ji, is_ter) = 0.
+            ELSE 
+                pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic)
+                IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN
+                    pctsrf(ji,is_ter) = 0.
+                    pctsrf(ji, is_lic) = zmasq(ji)
+                ENDIF 
+            ENDIF 
+        ENDIF 
+      END DO 
+C
+C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0)
+C
+      pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon))
+
+
+      WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA)
+          pctsrf(1 : klon, is_oce) = 0.
+      END WHERE 
+
+      if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon)
+
+      isst = 0
+      where (pctsrf(2:klon-1,is_oce) >0.) isst = 1
+C
+C verif que somme des sous surface = 1
+C
+      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf),dim=2))-1.0) 
+     $    .GT. EPSFRA)
+      IF (ji .NE. 0) THEN
+          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+      ENDIF 
+
+!      where (pctsrf(1:klon, is_ter) >= .5) 
+!        pctsrf(1:klon, is_ter) = 1.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 1.
+!      endwhere
+!      where (pctsrf(1:klon, is_lic) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 1.
+!        zmasq = 1.
+!      endwhere
+!      where (pctsrf(1:klon, is_oce) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 1.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 0.
+!      endwhere
+!      where (pctsrf(1:klon, is_sic) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 1.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 0.
+!      endwhere
+!      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+C
+C verif que somme des sous surface = 1
+C
+!      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) 
+!     $    .GT. EPSFRA)
+!      IF (ji .NE. 0) THEN
+!          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+!     ENDIF 
+
+      CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d)
+      write(*,*)'zmasq = '
+      write(*,'(96i1)')nint(zx_tmp_2d)
+      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+      WRITE(*,*) 'MASQUE construit : Masque'
+      WRITE(*,'(97I1)') nINT(masque(:,:))
+
+
+
+C Calcul intermediaire
+c 
+      CALL massdair( p3d, masse  )
+c
+
+      print *,' ALPHAX ',alphax
+
+      DO  l = 1, llm
+        DO  i    = 1, iim
+          xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+          xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+        ENDDO
+          xpn      = SUM(xppn)/apoln
+          xps      = SUM(xpps)/apols
+        DO i   = 1, iip1
+          masse(   i   ,   1     ,  l )   = xpn
+          masse(   i   ,   jjp1  ,  l )   = xps
+        ENDDO
+      ENDDO
+      q3d(iip1,:,:,:) = q3d(1,:,:,:)
+      phis(iip1,:) = phis(1,:)
+
+C init pour traceurs
+      call iniadvtrac(nq)
+C Ecriture
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+      print*,'sortie inidissip'
+      itau = 0
+      itau_dyn = 0
+      itau_phy = 0
+      iday = dayref +itau/day_step
+      time = FLOAT(itau-(iday-dayref)*day_step)/day_step
+c     
+      IF(time.GT.1)  THEN
+       time = time - 1
+       iday = iday + 1
+      ENDIF
+      day_ref = dayref
+      annee_ref = anneeref
+
+      CALL geopot  ( ip1jmp1, tpot  , pk , pks,  phis  , phi   )
+      print*,'sortie geopot'
+      
+      CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis ,
+     *                phi,w, pbaru,pbarv,time+iday-dayref   )
+       print*,'sortie caldyn0'     
+      CALL dynredem0("start.nc",dayref,phis,nqmx)
+      print*,'sortie dynredem0'
+      CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,nqmx,masse ,
+     .                            psol)
+      print*,'sortie dynredem1' 
+C
+C Ecriture etat initial physique
+C
+      write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad
+      phystep   = dtvr * FLOAT(iphysiq)
+      radpas    = NINT (86400./phystep/ FLOAT(nbapp_rad) )
+      write(*,*)'phystep =', phystep, radpas
+cIM : lecture de co2_ppm & solaire ds physiq.def
+c     co2_ppm   = 348.0
+c     solaire   = 1365.0
+
+c
+c Initialisation 
+c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs
+c
+      tsolsrf(:,is_ter) = tsol
+      tsolsrf(:,is_lic) = tsol
+      tsolsrf(:,is_oce) = tsol
+      tsolsrf(:,is_sic) = tsol
+      snsrf(:,is_ter) = sn
+      snsrf(:,is_lic) = sn
+      snsrf(:,is_oce) = sn
+      snsrf(:,is_sic) = sn
+      albe(:,is_ter) = 0.08
+      albe(:,is_lic) = 0.6
+      albe(:,is_oce) = 0.5
+      albe(:,is_sic) = 0.6
+      alblw = albe
+      evap(:,:) = 0.
+      qsolsrf(:,is_ter) = 150
+      qsolsrf(:,is_lic) = 150
+      qsolsrf(:,is_oce) = 150.
+      qsolsrf(:,is_sic) = 150.
+      do i = 1, nbsrf
+        do j = 1, nsoilmx
+          tsoil(:,j,i) = tsol
+        enddo
+      enddo
+      rain_fall = 0.; snow_fall = 0.
+      solsw = 165.
+      sollw = -53.
+      t_ancien = 273.15
+      q_ancien = 0.
+      agesno = 0.
+cIM "slab" ocean
+      tslab(1:klon) = tsolsrf(1:klon,is_oce)
+      seaice = 0. !kg m-2
+c
+      frugs(1:klon,is_oce) = rugmer(1:klon)
+      frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0)
+      frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0)
+      frugs(1:klon,is_sic) = 0.001
+      fder = 0.0
+      clwcon = 0.0
+      rnebcon = 0.0
+      ratqs = 0.0
+      run_off_lic_0 = 0.0 
+
+c
+c Avant l'appel a phyredem, on initialize les modules de surface
+c avec les valeurs qui vont etre ecrit dans startphy.nc
+c
+      dummy(:,:) = 1.0
+      ocean = "slab"
+      pbl_tke(:,:,:) = 1.e-8 
+      zmax0(:) = 40.
+      f0(:) = 1.e-5
+      ema_work1(:,:) = 0.
+      ema_work2(:,:) = 0.
+
+      call fonte_neige_init(run_off_lic_0)
+      call pbl_surface_init(qsol, fder, snsrf, qsolsrf,
+     $     evap, frugs, agesno, tsoil)
+      call ocean_slab_init(dummy(1,1), tslab, seaice, dummy(:,:))
+
+      call phyredem("startphy.nc")
+
+
+
+C     Sortie Visu pour les champs dynamiques
+      if (1.eq.0 ) then
+      print*,'sortie visu'
+      time_step = 1.
+      t_ops = 2.
+      t_wrt = 2.
+      itau = 2.
+      visu_file='Etat0_visu.nc'
+      CALL initdynav(visu_file,dayref,anneeref,time_step,
+     .              t_ops, t_wrt, nqmx, visuid)
+      CALL writedynav(visuid, nqmx, itau,vvent ,
+     .                uvent,tpot,pk,phi,q3d,masse,psol,phis)
+      else
+         print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0'
+      endif
+      print*,'entree histclo'
+      CALL histclo
+      RETURN
+      !
+      END SUBROUTINE etat0_netcdf
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/exner_hyb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/exner_hyb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/exner_hyb.F	(revision 984)
@@ -0,0 +1,114 @@
+!
+! $Header$
+!
+      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+c
+      
+      unpl2k    = 1.+ 2.* kappa
+c
+      DO   ij  = 1, ngrid
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+
+      DO  ij   = 1, iim
+        ppn(ij) = aire(   ij   ) * pks(  ij     )
+        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+      ENDDO
+      xpn      = SSUM(iim,ppn,1) /apoln
+      xps      = SSUM(iim,pps,1) /apols
+
+      DO ij   = 1, iip1
+        pks(   ij     )  =  xpn
+        pks( ij+ip1jm )  =  xps
+      ENDDO
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+      DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+        DO ij = 1, ngrid
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c
+      ENDDO
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+      DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+        DO   ij   = 1, ngrid
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+      ENDDO
+c
+c
+      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/extrapol.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/extrapol.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/extrapol.F	(revision 984)
@@ -0,0 +1,200 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE extrapol (pfild, kxlon, kylat, pmask,
+     .                   norsud, ldper, knbor, pwork)
+      IMPLICIT none
+c
+c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
+c Fill up missed values by using the neighbor points
+c
+      INTEGER kxlon, kylat ! longitude and latitude dimensions (Input)
+      INTEGER knbor ! minimum neighbor number (Input)
+      LOGICAL norsud ! True if field is from North to South (Input)
+      LOGICAL ldper ! True if take into account the periodicity (Input)
+      REAL pmask ! mask value (Input)
+      REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
+      REAL pwork(kxlon,kylat) ! working space
+c
+      REAL zwmsk
+      INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
+      INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates
+      REAL zmask(9)
+C
+C  We search over the eight closest neighbors
+C
+C            j+1  7  8  9
+C              j  4  5  6    Current point 5 --> (i,j)
+C            j-1  1  2  3
+C                i-1 i i+1
+c
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      incre = 0
+c
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         pwork(i,j) = pfild(i,j)
+      ENDDO
+      ENDDO
+c
+C* To avoid problems in floating point tests
+      zwmsk = pmask - 1.0
+c
+200   CONTINUE
+      incre = incre + 1
+      DO 99999 j = 1, kylat
+      DO 99999 i = 1, kxlon
+      IF (pfild(i,j).GT. zwmsk) THEN
+         pwork(i,j) = pfild(i,j)
+         inbor = 0
+         ideb = 1
+         ifin = 9
+C
+C* Fill up ix array
+         ix(1) = MAX (1,i-1)
+         ix(2) = i
+         ix(3) = MIN (kxlon,i+1)
+         ix(4) = MAX (1,i-1)
+         ix(5) = i
+         ix(6) = MIN (kxlon,i+1)
+         ix(7) = MAX (1,i-1)
+         ix(8) = i
+         ix(9) = MIN (kxlon,i+1)
+C
+C* Fill up iy array
+         jy(1) = MAX (1,j-1)
+         jy(2) = MAX (1,j-1)
+         jy(3) = MAX (1,j-1)
+         jy(4) = j
+         jy(5) = j
+         jy(6) = j
+         jy(7) = MIN (kylat,j+1)
+         jy(8) = MIN (kylat,j+1)
+         jy(9) = MIN (kylat,j+1)
+C
+C* Correct latitude bounds if southernmost or northernmost points
+         IF (j .EQ. 1) ideb = 4
+         IF (j .EQ. kylat) ifin = 6
+C
+C* Account for periodicity in longitude
+C
+         IF (ldper) THEN 
+            IF (i .EQ. kxlon) THEN
+               ix(3) = 1
+               ix(6) = 1
+               ix(9) = 1
+            ELSE IF (i .EQ. 1) THEN
+               ix(1) = kxlon
+               ix(4) = kxlon
+               ix(7) = kxlon
+            ENDIF
+         ELSE
+            IF (i .EQ. 1) THEN
+               ix(1) = i
+               ix(2) = i + 1
+               ix(3) = i
+               ix(4) = i + 1
+               ix(5) = i
+               ix(6) = i + 1
+            ENDIF 
+            IF (i .EQ. kxlon) THEN
+               ix(1) = i -1
+               ix(2) = i
+               ix(3) = i - 1
+               ix(4) = i
+               ix(5) = i - 1
+               ix(6) = i
+            ENDIF
+C
+            IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN 
+               jy(1) = MAX (1,j-1)
+               jy(2) = MAX (1,j-1)
+               jy(3) = j
+               jy(4) = j
+               jy(5) = MIN (kylat,j+1)
+               jy(6) = MIN (kylat,j+1)
+C
+               ideb = 1
+               ifin = 6
+               IF (j .EQ. 1) ideb = 3
+               IF (j .EQ. kylat) ifin = 4
+            ENDIF
+         ENDIF ! end for ldper test
+C
+C* Find unmasked neighbors
+C
+         DO 230 k = ideb, ifin
+            zmask(k) = 0.
+            ilon = ix(k)
+            jlat = jy(k)
+            IF (pfild(ilon,jlat) .LT. zwmsk) THEN
+               zmask(k) = 1.
+               inbor = inbor + 1
+            ENDIF
+ 230     CONTINUE
+C
+C* Not enough points around point P are unmasked; interpolation on P 
+C  will be done in a future call to extrap.
+C
+         IF (inbor .GE. knbor) THEN
+            pwork(i,j) = 0.
+            DO k = ideb, ifin
+               ilon = ix(k)
+               jlat = jy(k)
+               pwork(i,j) = pwork(i,j)
+     $                      + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor)
+            ENDDO
+         ENDIF
+C
+      ENDIF
+99999 CONTINUE
+C
+C*    3. Writing back unmasked field in pfild
+C        ------------------------------------
+C
+C* pfild then contains:
+C     - Values which were not masked
+C     - Interpolated values from the inbor neighbors
+C     - Values which are not yet interpolated
+C
+      idoit = 0
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1
+         pfild(i,j) = pwork(i,j)
+      ENDDO
+      ENDDO
+c
+      IF (idoit .ne. 0) GOTO 200
+ccc      PRINT*, "Number of extrapolation steps incre =", incre
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/flumass.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/flumass.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/flumass.F	(revision 984)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
+     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
+     * pbarv( ip1jm,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+
+      REAL       SSUM
+
+
+      DO  5 l = 1,llm
+
+      DO  1 ij = iip2,ip1jm
+      pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1  CONTINUE
+
+      DO 3 ij = 1,ip1jm
+      pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      sairen = SSUM( iim,  aire(   1     ), 1 )
+      saireun= SSUM( iim, aireu(   1     ), 1 )
+      saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+      saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+      DO 20 l = 1,llm
+
+      ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+
+      pbaru(    1   ,l )=   pbarv(    1     ,l ) - ctn * aire(    1    )
+      pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 )
+
+      DO 11 i = 2,iim
+      pbaru(    i    ,l ) = pbaru(   i - 1   ,l )    +
+     *                      pbarv(    i      ,l ) - ctn * aire(   i    )
+
+      pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l )    -
+     *                      pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm)
+  11  CONTINUE
+      DO 12 i = 1,iim
+      apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+      apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+  12  CONTINUE
+      ctn0 = -SSUM( iim,apbarun,1 )/saireun
+      cts0 = -SSUM( iim,apbarus,1 )/saireus
+      DO 14 i = 1,iim
+      pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+      pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+  14  CONTINUE
+
+      pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+      pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+  20  CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/fluxstokenc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/fluxstokenc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/fluxstokenc.F	(revision 984)
@@ -0,0 +1,162 @@
+      SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     . time_step,itau )
+
+       USE IOIPSL
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "tracstoke.h"
+#include "temps.h"
+
+      REAL time_step,t_wrt, t_ops
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+      REAL phis(ip1jmp1)
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
+
+      REAL pbarvst(iip1,jjp1,llm),zistdyn
+	real dtcum
+
+      INTEGER iadvtr,ndex(1) 
+      integer nscal
+      real tst(1),ist(1),istp(1)
+      INTEGER ij,l,irec,i,j,itau
+      INTEGER, SAVE :: fluxid, fluxvid,fluxdid
+ 
+      SAVE iadvtr, massem,pbaruc,pbarvc,irec
+      SAVE phic,tetac
+      logical first
+      save first
+      data first/.true./
+      DATA iadvtr/0/
+
+
+c AC initialisations
+      pbarug(:,:)   = 0.
+      pbarvg(:,:,:) = 0.
+      wg(:,:)       = 0.
+      
+
+      if(first) then
+
+	CALL initfluxsto( 'fluxstoke',
+     .  time_step,istdyn* time_step,istdyn* time_step,
+     . nqmx, fluxid,fluxvid,fluxdid) 
+	
+	ndex(1) = 0
+        call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
+        call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
+	
+	ndex(1) = 0
+        nscal = 1
+        tst(1) = time_step
+        call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
+        ist(1)=istdyn
+        call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
+        istp(1)= istphy
+        call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
+	
+	first = .false.
+
+      endif
+
+
+      IF(iadvtr.EQ.0) THEN
+         CALL initial0(ijp1llm,phic)
+         CALL initial0(ijp1llm,tetac)
+         CALL initial0(ijp1llm,pbaruc)
+         CALL initial0(ijmllm,pbarvc)
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+            phic(ij,l) = phic(ij,l) + phi(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.istdyn ) THEN
+c    normalisation
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
+            tetac(ij,l) = tetac(ij,l)/float(istdyn)
+            phic(ij,l) = phic(ij,l)/float(istdyn)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
+         ENDDO
+      ENDDO
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+        do l=1,llm
+           do j=1,jjm
+              do i=1,iip1
+                 pbarvst(i,j,l)=pbarvg(i,j,l)
+              enddo
+           enddo
+           do i=1,iip1
+              pbarvst(i,jjp1,l)=0.
+           enddo
+        enddo
+
+         iadvtr=0
+	Print*,'ITAU auqel on stoke les fluxmasses',itau
+	
+	call histwrite(fluxid, 'masse', itau, massem,
+     .               iip1*jjp1*llm, ndex)
+	
+	call histwrite(fluxid, 'pbaru', itau, pbarug,
+     .               iip1*jjp1*llm, ndex)
+	
+	call histwrite(fluxvid, 'pbarv', itau, pbarvg,
+     .               iip1*jjm*llm, ndex)
+	
+        call histwrite(fluxid, 'w' ,itau, wg, 
+     .             iip1*jjp1*llm, ndex) 
+	
+	call histwrite(fluxid, 'teta' ,itau, tetac, 
+     .             iip1*jjp1*llm, ndex) 
+	
+	call histwrite(fluxid, 'phi' ,itau, phic, 
+     .             iip1*jjp1*llm, ndex) 
+	
+C
+
+      ENDIF ! if iadvtr.EQ.istdyn
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/friction.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/friction.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/friction.F	(revision 984)
@@ -0,0 +1,99 @@
+!
+! $Header$
+!
+c=======================================================================
+      SUBROUTINE friction(ucov,vcov,pdt)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c
+c   Objet:
+c   ------
+c
+c  ***********
+c    Friction
+c  ***********
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "comconst.h"
+
+      REAL pdt
+      REAL modv(iip1,jjp1),zco,zsi
+      REAL vpn,vps,upoln,upols,vpols,vpoln
+      REAL u2(iip1,jjp1),v2(iip1,jjm)
+      REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm )
+      INTEGER  i,j
+      REAL cfric
+      parameter (cfric=1.e-5)
+
+
+c   calcul des composantes au carre du vent naturel
+      do j=1,jjp1
+         do i=1,iip1
+            u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+         enddo
+      enddo
+      do j=1,jjm
+         do i=1,iip1
+            v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+         enddo
+      enddo
+
+c   calcul du module de V en dehors des poles
+      do j=2,jjm
+         do i=2,iip1
+            modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+         enddo
+         modv(1,j)=modv(iip1,j)
+      enddo
+
+c   les deux composantes du vent au pole sont obtenues comme
+c   premiers modes de fourier de v pres du pole
+      upoln=0.
+      vpoln=0.
+      upols=0.
+      vpols=0.
+      do i=2,iip1
+         zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+         zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+         vpn=vcov(i,1,1)/cv(i,1)
+         vps=vcov(i,jjm,1)/cv(i,jjm)
+         upoln=upoln+zco*vpn
+         vpoln=vpoln+zsi*vpn
+         upols=upols+zco*vps
+         vpols=vpols+zsi*vps
+      enddo
+      vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+      vps=sqrt(upols*upols+vpols*vpols)/pi
+      do i=1,iip1
+c        modv(i,1)=vpn
+c        modv(i,jjp1)=vps
+         modv(i,1)=modv(i,2)
+         modv(i,jjp1)=modv(i,jjm)
+      enddo
+
+c   calcul du frottement au sol.
+      do j=2,jjm
+         do i=1,iim
+            ucov(i,j,1)=ucov(i,j,1)
+     s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+         enddo
+         ucov(iip1,j,1)=ucov(1,j,1)
+      enddo
+      do j=1,jjm
+         do i=1,iip1
+            vcov(i,j,1)=vcov(i,j,1)
+     s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+         enddo
+         vcov(iip1,j,1)=vcov(1,j,1)
+      enddo
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/fxhyp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/fxhyp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/fxhyp.F	(revision 984)
@@ -0,0 +1,448 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
+
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+c    Calcule les longitudes et derivees dans la grille du GCM pour une
+c     fonction f(x) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
+c     dzoom  etant  la distance totale de la zone du zoom
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
+c
+c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
+c   ********************************************************************
+
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+       LOGICAL scal180
+       PARAMETER ( scal180 = .TRUE. )
+
+c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
+c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
+c      sinon scal180 = .FALSE.
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,dzooma,tau,grossism
+
+c    ......   arguments  de  sortie  ......
+
+       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
+     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
+
+c     .... variables locales  ....
+c
+       REAL   dzoom
+       REAL*8 xlon(iip1),xprimm(iip1),xuv
+       REAL*8 xtild(0:nmax2)
+       REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
+       REAL*8 Xf(0:nmax2),xxpr(0:nmax2)
+       REAL*8 xvrai(iip1),xxprim(iip1) 
+       REAL*8 pi,depi,epsilon,xzoom,fa,fb
+       REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2
+       INTEGER i,it,ik,iter,ii,idif,ii1,ii2
+       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL*8 champmin,champmax,decalx
+       INTEGER is2
+       SAVE is2
+
+       REAL*8 heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-3
+       xzoom    = xzoomdeg * pi/180. 
+c
+           decalx   = .75
+       IF( grossism.EQ.1..AND.scal180 )  THEN
+           decalx   = 1.
+       ENDIF
+
+       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
+c
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * depi
+       ELSEIF( dzooma.LT. 25. ) THEN
+         WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) xzoom,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        xtild(i) = - pi + FLOAT(i) * depi /nmax2
+       ENDDO
+
+       DO i = nmax, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fhyp ( i ) = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fhyp ( i )  =   1.
+                ENDIF
+            ELSE
+                    fhyp ( i )  =  TANH ( fa/fb )
+            ENDIF
+         ENDIF
+        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
+        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+
+       ffdx = 0.
+
+       DO i = nmax +1,nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fxm   = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fxm   =   1.
+                ENDIF
+            ELSE
+                    fxm   =  TANH ( fa/fb )
+            ENDIF
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm  =  1.
+       IF ( xmoy.EQ. pi )  fxm  = -1.
+
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT
+       ENDIF
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = nmax, nmax2
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i =  nmax+1, nmax2
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+       Xf(0) = - pi
+
+       DO i =  nmax +1, nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm =  1.
+       IF ( xmoy.EQ. pi )  fxm = -1.
+       xxpr(i)    = beta + ( grossism - beta ) * fxm
+
+       ENDDO
+
+       DO i = nmax+1, nmax2
+        xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1, 4
+
+       IF( ik.EQ.1 )        THEN
+         xuv =  -0.25
+       ELSE IF ( ik.EQ.2 )  THEN
+         xuv =   0.
+       ELSE IF ( ik.EQ.3 )  THEN
+         xuv =   0.50
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+      xo1   = 0.
+
+      ii1=1
+      ii2=iim
+      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
+        ii1 = 2 
+        ii2 = iim+1
+      ENDIF
+      DO 1500 i = ii1, ii2
+
+      xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim) 
+
+      Xfi    = xlon2
+c
+      DO 250 it =  nmax2,0,-1
+      IF( Xfi.GE.Xf(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+
+350   CONTINUE
+
+c    ......  Calcul de   Xf(xi)    ...... 
+c
+      xi  = xtild(it)
+
+      IF(it.EQ.nmax2)  THEN
+       it       = nmax2 -1
+       Xf(it+1) = pi
+      ENDIF
+c  .....................................................................
+c
+c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
+c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
+c          et (Xf(it+1),xtild(it+1) )
+
+       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
+     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
+
+       Xf1     = Xf(it)
+       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
+
+       DO 500 iter = 1,300
+        xi = xi - ( Xf1 - Xfi )/ Xprimin
+
+        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
+         xo1      = xi
+         xi2      = xi * xi
+         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
+         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
+550   CONTINUE
+
+       xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
+
+1500   CONTINUE
+
+
+       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
+         xvrai(1)    = xvrai(iip1)-depi
+         xxprim(1)   = xxprim(iip1)
+       ENDIF
+       DO i = 1 , iim
+        xlon(i)     = xvrai(i)
+        xprimm(i)   = xxprim(i)
+       ENDDO
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
+        ENDIF
+       ENDDO
+c
+c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
+c   ........................................................................
+
+       champmin =  1.e12
+       champmax = -1.e12
+       DO i = 1, iim
+        champmin = MIN( champmin,xvrai(i) )
+        champmax = MAX( champmax,xvrai(i) )
+       ENDDO
+
+      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
+                GO TO 1600
+      ELSE
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
+ 80       CONTINUE
+          is2 = i
+          ENDIF
+
+          IF( is2.NE. 1 )  THEN
+            DO ii = is2 , iim
+             xlon  (ii-is2+1) = xvrai(ii)
+             xprimm(ii-is2+1) = xxprim(ii)
+            ENDDO
+            DO ii = 1 , is2 -1
+             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
+             xprimm(ii+iim-is2+1) = xxprim(ii) 
+            ENDDO
+          ENDIF
+        ELSE 
+          IF( ik.EQ.1 )  THEN
+           DO i = iim,1,-1
+             IF( xvrai(i).LE. pi ) GO TO 90
+           ENDDO
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+           idif = iim -is2
+           DO ii = 1, is2
+            xlon  (ii+idif) = xvrai(ii)
+            xprimm(ii+idif) = xxprim(ii)
+           ENDDO
+           DO ii = 1, idif
+            xlon (ii)  = xvrai (ii+is2) - depi
+            xprimm(ii) = xxprim(ii+is2) 
+           ENDDO
+         ENDIF
+      ENDIF
+c
+c     .........   Fin  de la reorganisation   ............................
+
+ 1600    CONTINUE
+
+
+         xlon  ( iip1)  = xlon(1) + depi
+         xprimm( iip1 ) = xprimm (1 )
+       
+         DO i = 1, iim+1
+         xvrai(i) = xlon(i)*180./pi
+         ENDDO
+
+         IF( ik.EQ.1 )  THEN
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim +1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.2 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.3)   THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.4 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+
+         ENDIF
+
+5000    CONTINUE
+c
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+18     FORMAT(/)
+24     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
+68     FORMAT(1x,7f9.2)
+566    FORMAT(1x,7f9.4)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/fxy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/fxy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/fxy.F	(revision 984)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+      IMPLICIT NONE
+
+c     Auteur  :  P. Le Van
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c           a tangente sinusoidale et eventuellement avec zoom  .
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "serre.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_new.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( FLOAT( j )        )
+         yprimu(j) = fyprim( FLOAT( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
+         rlatu1(j) = fy    ( FLOAT( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( FLOAT( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( FLOAT( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
+        yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   FLOAT( i )          )
+           rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
+        rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
+        rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  FLOAT( i )          )
+         xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/fxyhyper.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/fxyhyper.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/fxyhyper.F	(revision 984)
@@ -0,0 +1,139 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy  ,   
+     ,                       xzoom, grossx, dzoomx,taux  ,
+     , rlatu,yprimu,rlatv,yprimv,rlatu1,  yprimu1,  rlatu2,  yprimu2  , 
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       IMPLICIT NONE
+c
+c      Auteur :  P. Le Van .
+c
+c      d'apres  formulations de R. Sadourny .
+c
+c
+c     Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp )
+c            par des  fonctions  a tangente hyperbolique .
+c
+c     Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom
+c                      et  yzoom )   :  
+c
+c     a) le grossissement du zoom  :  grossy  ( en y ) et grossx ( en x )
+c     b) l' extension     du zoom  :  dzoomy  ( en y ) et dzoomx ( en x )
+c     c) la raideur de la transition du zoom  :   taux et tauy   
+c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+
+c   .....  Arguments  ...
+c
+       REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+       REAL*8  dxmin, dxmax , dymin, dymax
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy  , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  dymin,dymax                                               )
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax         )
+
+
+        DO i = 1, iip1
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         STOP 13
+       ENDIF
+c
+       IF(rlatu2(j).LE.rlatu(j+1))  THEN
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FY **** '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Latitudes  '
+        WRITE(6,*) ' *********** '
+        WRITE(6,18)
+        WRITE(6,3)  dymin, dymax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Longitudes  '
+        WRITE(6,*) ' ************ '
+        WRITE(6,18)
+        WRITE(6,3)  dxmin, dxmax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+        WRITE(6,18)
+c
+3      Format(1x, ' Au centre du zoom , la longueur de la maille est',
+     ,  ' d environ ',f8.2 ,' degres  ',
+     , ' alors que la maille en dehors de la zone du zoom est d environ
+     , ', f8.2,' degres ' )
+18      FORMAT(/)
+
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/fxysinus.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/fxysinus.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/fxysinus.F	(revision 984)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+
+      IMPLICIT NONE
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c            avec y = Asin( j )  .
+c
+c     Auteur  :  P. Le Van
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_sin.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( FLOAT( j )        )
+         yprimu(j) = fyprim( FLOAT( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
+         rlatu1(j) = fy    ( FLOAT( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( FLOAT( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( FLOAT( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
+        yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   FLOAT( i )          )
+           rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
+        rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
+        rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  FLOAT( i )          )
+         xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/fyhyp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/fyhyp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/fyhyp.F	(revision 984)
@@ -0,0 +1,378 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau  ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  champmin,champmax                                            ) 
+
+cc    ...  Version du 01/04/2001 ....
+
+       IMPLICIT NONE
+c
+c    ...   Auteur :  P. Le Van  ... 
+c
+c    .......    d'apres  formulations  de R. Sadourny  .......
+c
+c     Calcule les latitudes et derivees dans la grille du GCM pour une
+c     fonction f(y) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc)
+c     dzoom  etant  la distance totale de la zone du zoom ( en radians )
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom   
+c
+c
+c N.B : Il vaut mieux avoir : grossism * dzoom  <  pi/2  (radians) ,en lati.
+c      ********************************************************************
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzooma,tau 
+c         ( rentres  par  run.def )
+
+c     .......  arguments  de sortie   .......
+c
+       REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+
+c
+c     .....     champs  locaux    .....
+c
+     
+       REAL   dzoom
+       REAL*8 ylat(jjp1), yprim(jjp1)
+       REAL*8 yuv
+       REAL*8 yt(0:nmax2)
+       REAL*8 fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2)
+       SAVE Ytprim, yt,Yf
+       REAL*8 Yf(0:nmax2),yypr(0:nmax2)
+       REAL*8 yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL*8 pi,depi,pis2,epsilon,y0,pisjm
+       REAL*8 yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax
+       REAL*8 yfi,Yf1,ffdy
+       REAL*8 ypn,deply,y00
+       SAVE y00, deply
+
+       INTEGER i,j,it,ik,iter,jlat
+       INTEGER jpn,jjpn
+       SAVE jpn
+       REAL*8 a0,a1,a2,a3,yi2,heavyy0,heavyy0m
+       REAL*8 fa(0:nmax2),fb(0:nmax2)
+       REAL y0min,y0max
+
+       REAL*8     heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       pis2     = pi/2.
+       pisjm    = pi/ FLOAT(jjm)
+       epsilon  = 1.e-3
+       y0       =  yzoomdeg * pi/180. 
+
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * pi
+       ELSEIF( dzooma.LT. 12. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,18)
+       WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) y0,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        yt(i) = - pis2  + FLOAT(i)* pi /nmax2
+       ENDDO
+
+       heavyy0m = heavyside( -y0 )
+       heavyy0  = heavyside(  y0 )
+       y0min    = 2.*y0*heavyy0m - pis2
+       y0max    = 2.*y0*heavyy0  + pis2
+
+       fa = 999.999
+       fb = 999.999
+       
+       DO i = 0, nmax2 
+        IF( yt(i).LT.y0 )  THEN
+         fa (i) = tau*  (yt(i)-y0+dzoom/2. )
+         fb(i) =   (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) )
+        ELSEIF ( yt(i).GT.y0 )  THEN
+         fa(i) =   tau *(y0-yt(i)+dzoom/2. )
+         fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) 
+       ENDIF
+        
+       IF( 200.* fb(i) .LT. - fa(i) )   THEN
+         fhyp ( i) = - 1.
+       ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fhyp ( i) =   1.
+       ELSE  
+         fhyp(i) =  TANH ( fa(i)/fb(i) )
+       ENDIF
+
+       IF( yt(i).EQ.y0 )  fhyp(i) = 1.
+       IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT
+
+       ENDIF
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax2
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+
+c   .....  Calcul  de  Yf     ........
+
+       Yf(0) = - pis2
+       DO i = 1, nmax2
+        yypr(i)    = beta + ( grossism - beta ) * fxm(i)
+       ENDDO
+
+       DO i=1,nmax2
+        Yf(i)   = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) )
+       ENDDO
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1,4
+
+       IF( ik.EQ.1 )  THEN
+         yuv  = 0.
+         jlat = jjm + 1
+       ELSE IF ( ik.EQ.2 )  THEN
+         yuv  = 0.5
+         jlat = jjm 
+       ELSE IF ( ik.EQ.3 )  THEN
+         yuv  = 0.25
+         jlat = jjm 
+       ELSE IF ( ik.EQ.4 )  THEN
+         yuv  = 0.75
+         jlat = jjm 
+       ENDIF
+c
+       yo1   = 0.
+       DO 1500 j =  1,jlat
+        yo1   = 0.
+        ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
+       DO 250 it =  nmax2,0,-1
+        IF( yfi.GE.Yf(it))  GO TO 350
+250    CONTINUE
+       it = 0
+350    CONTINUE
+
+       yi = yt(it)
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = pis2
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1),   
+     ,                  yt(it),yt(it+1) ,   a0,a1,a2,a3   )      
+
+       Yf1     = Yf(it)
+       Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi
+
+       DO 500 iter = 1,300
+         yi = yi - ( Yf1 - yfi )/ Yprimin
+
+        IF( ABS(yi-yo1).LE.epsilon)  GO TO 550
+         yo1      = yi
+         yi2      = yi * yi
+         Yf1      = a0 +  a1 * yi +     a2 * yi2  +     a3 * yi2 * yi
+         Yprimin  =       a1      + 2.* a2 *  yi  + 3.* a3 * yi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
+550   CONTINUE
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
+
+1500    CONTINUE
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         WRITE(6,*) ' PBS. avec  rlat(',j+1,') plus petit que rlat(',j,
+     ,  ')'
+         STOP 3
+        ENDIF
+       ENDDO
+
+       WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2'
+     , ,' et  pi/2 '
+c
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 
+          DO j = jlat,1,-1
+           IF( yvrai(j).LE. ypn ) GO TO 1502
+          ENDDO
+1502     CONTINUE
+
+         jpn   = j
+         y00   = yvrai(jpn)
+         deply = pis2 -  y00
+        ENDIF
+
+         DO  j = 1, jjm +1 - jpn
+           ylatt (j)  = -pis2 - y00  + yvrai(jpn+j-1)
+           yprimm(j)  = yprim(jpn+j-1)
+         ENDDO
+
+         jjpn  = jpn
+         IF( jlat.EQ. jjm ) jjpn = jpn -1
+
+         DO j = 1,jjpn 
+          ylatt (j + jjm+1 -jpn) = yvrai(j) + deply
+          yprimm(j + jjm+1 -jpn) = yprim(j)
+         ENDDO
+
+c      ***********   Fin de la reorganisation     *************
+c
+ 1600   CONTINUE
+
+       DO j = 1, jlat
+          ylat(j) =  ylatt( jlat +1 -j )
+         yprim(j) = yprimm( jlat +1 -j )
+       ENDDO
+  
+        DO j = 1, jlat
+         yvrai(j) = ylat(j)*180./pi
+        ENDDO
+
+        IF( ik.EQ.1 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U   apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 2 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*) ' YLAT   en V  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*)' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 3 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U + 0.75  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT en U + 0.25  apres ( en  deg. ) '
+c         WRITE(6,68)(yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,68) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+
+        ENDIF
+
+5000   CONTINUE
+c
+        WRITE(6,18)
+c
+c  .....     fin de la boucle  do 5000 .....
+
+        DO j = 1, jjm
+         ylat(j) = rrlatu(j) - rrlatu(j+1)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO j = 1, jjm
+         champmin = MIN( champmin, ylat(j) )
+         champmax = MAX( champmax, ylat(j) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+24     FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3)
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gcm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gcm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gcm.F	(revision 984)
@@ -0,0 +1,445 @@
+!
+! $Header$
+!
+c
+c
+      PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#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
+      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+#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"
+#include "advtrac.h"
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+      SAVE  clesphy0
+
+
+
+      REAL zdtvr
+      INTEGER nbetatmoy, nbetatdem,nbetat
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu 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
+
+      REAL rdayvrai,rdaym_ini,rday_ecri
+      LOGICAL first
+
+      LOGICAL call_iniphys
+      data call_iniphys/.true./
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+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
+
+C Calendrier
+      LOGICAL true_calendar
+      PARAMETER (true_calendar = .false.)
+
+c-----------------------------------------------------------------------
+c    variables pour l'initialisation de la physique :
+c    ------------------------------------------------
+      INTEGER ngridmx,nq
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx)
+      REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
+
+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 initialisation Anne
+      hadv_flg(:) = 0.
+      vadv_flg(:) = 0.
+      conv_flg(:) = 0.
+      pbl_flg(:)  = 0. 
+      tracnam(:)  = '        ' 
+      nprath = 1
+      nbtrac = 0
+      mmt_adj(:,:,:,:) = 1
+
+
+c--------------------------------------------------------------------------
+c   Iflag_phys controle l'appel a la physique :
+c   -------------------------------------------
+c      0 : pas de physique
+c      1 : Normale (appel a phylmd, phymars ...)
+c      2 : rappel Newtonien pour la temperature + friction au sol
+      iflag_phys=1
+
+c--------------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+c     T : on lit start.nc
+c     F : le modele s'autoinitialise avec un cas academique (iniacademic)
+      read_start=.true.
+#ifdef CPP_IOIPSL
+#else
+      read_start=.false.
+#endif
+#ifdef CPP_PHYS
+#else
+      read_start=.false.
+#endif
+
+c-----------------------------------------------------------------------
+c   Choix du calendrier
+c   -------------------
+
+#ifdef CPP_IOIPSL
+      if (true_calendar) then
+        call ioconf_calendar('gregorian')
+      else
+        call ioconf_calendar('360d')
+      endif
+#endif
+c----------------------------------------------------------------------
+c  lecture des fichiers gcm.def ou run.def
+c  ---------------------------------------
+c
+#ifdef CPP_IOIPSL
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+#else
+      CALL defrun( 99, .TRUE. , clesphy0 )
+#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,nqmx-2,1,(jjm-1)*iim+2)
+      call InitComgeomphy
+#endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+      call init_const_lmdz(nbtrac,anneeref,dayref,iphysiq,day_step,nday)
+      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 schema pour l'advection
+c  dans fichier trac.def ou via INCA
+
+       call iniadvtrac(nq)
+c
+c-----------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+
+c  lecture du fichier start.nc
+      if (read_start) then
+#ifdef CPP_IOIPSL
+         CALL dynetat0("start.nc",nqmx,vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+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
+      endif
+
+      IF (config_inca /= 'none') 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,*)
+     .                 'AVANT iniacademic AVANT AVANT AVANT AVANT'
+      if (.not.read_start) then
+         CALL iniacademic(nqmx,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/FLOAT(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         WRITE(lunout,*)
+     .    'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+C
+C on remet le calendrier à zero si demande
+c
+      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+        write(lunout,*)
+     .  ' Attention les dates initiales lues dans le fichier'
+        write(lunout,*)
+     .  ' restart ne correspondent pas a celles lues dans '
+        write(lunout,*)' gcm.def'
+        if (raz_date .ne. 1) then
+          write(lunout,*)
+     .    ' 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,*)
+     .   ' On reinitialise a la date lue dans gcm.def'
+        endif
+      ELSE
+        raz_date = 0
+      endif
+
+
+c  nombre d'etats dans les fichiers demarrage et histoire
+      nbetatdem = nday / iecri
+      nbetatmoy = nday / periodav + 1
+
+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
+c
+c-----------------------------------------------------------------------
+c   Initialisation de la dissipation :
+c   ----------------------------------
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+
+c-----------------------------------------------------------------------
+c   Initialisation de la physique :
+c   -------------------------------
+#ifdef CPP_PHYS
+      IF (call_iniphys.and.iflag_phys.eq.1) THEN
+         latfi(1)=rlatu(1)
+         lonfi(1)=0.
+         zcufi(1) = cu(1)
+         zcvfi(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)
+               zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i)
+               zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i)
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)
+         lonfi(ngridmx)= 0.
+         zcufi(ngridmx) = cu(ip1jm+1)
+         zcvfi(ngridmx) = cv(ip1jm-iim)
+         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+         WRITE(lunout,*)
+     .           'WARNING!!! vitesse verticale nulle dans la physique'
+         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys ,
+     ,                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp     )
+         call_iniphys=.false.
+      ENDIF
+#endif
+
+c  numero de stockage pour les fichiers de redemarrage:
+
+c-----------------------------------------------------------------------
+c   Initialisation des I/O :
+c   ------------------------
+
+
+      day_end = day_ini + nday
+      WRITE(lunout,300)day_ini,day_end
+
+#ifdef CPP_IOIPSL
+      CALL dynredem0("restart.nc", day_end, phis, nqmx)
+
+      ecripar = .TRUE.
+
+      if ( 1.eq.1) then
+      time_step = zdtvr
+      t_ops = iecri * daysec
+      t_wrt = iecri * daysec
+      CALL inithist(dynhist_file,day_ref,annee_ref,time_step,
+     .              t_ops, t_wrt, nqmx, histid, histvid)
+
+      t_ops = iperiod * time_step
+      t_wrt = periodav * daysec
+      CALL initdynav(dynhistave_file,day_ref,annee_ref,time_step,
+     .              t_ops, t_wrt, nqmx, histaveid)
+
+      dtav = iperiod*dtvr/daysec
+      endif
+
+
+#endif
+
+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,nq,q,clesphy0,
+     .              time_0)
+
+
+
+ 300  FORMAT('1'/,15x,'run du pas',i7,2x,'au pas',i7,2x,
+     . 'c''est a dire du jour',i7,3x,'au jour',i7//)
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/geopot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/geopot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/geopot.F	(revision 984)
@@ -0,0 +1,64 @@
+!
+! $Header$
+!
+      SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    ....   calcul du geopotentiel aux milieux des couches    .....
+c    *******************************************************************
+c
+c     ....   l'integration se fait de bas en haut  ....
+c
+c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+c              phi               est un  argum. de sortie pour le s-pg .
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER ngrid
+      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
+     *       phi(ngrid,llm)
+
+
+c   Local:
+c   ------
+
+      INTEGER  l, ij
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+
+      DO   1  ij  = 1, ngrid
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+   1  CONTINUE
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = 1,ngrid
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/getparam.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/getparam.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/getparam.F90	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+MODULE getparam
+   USE IOIPSL
+   INTERFACE getpar
+     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml
+   END INTERFACE
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    open(out_eff,file=fichier,status='unknown',form='formatted') 
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+    !
+    IMPLICIT NONE
+    !
+    close(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) comment
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gr_dyn_fi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gr_dyn_fi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gr_dyn_fi.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/gr_ecrit_fi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gr_ecrit_fi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gr_ecrit_fi.F	(revision 984)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+	SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi)
+
+	IMPLICIT none
+
+c Transformer une variable de la grille d'ecriture a la grille physique
+	
+	INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield)
+c
+      INTEGER i, j, n, ig
+c
+c	print*,'iim jjm ',iim,jjm
+
+c modif par abd 21 02 01
+
+        jjm = jjmp1 - 1
+	do n = 1, nfield
+	    fi(1,n) = ecrit(1,1,n)
+            fi(nlon,n) = ecrit(1,jjm+1,n)
+         DO j = 2, jjm
+            ig = 2+(j-2)*iim
+            DO i = 1, iim
+	     fi(ig-1+i,n) = ecrit(i,j,n)
+            ENDDO
+         ENDDO
+      ENDDO
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gr_fi_dyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gr_fi_dyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gr_fi_dyn.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/gr_int_dyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gr_int_dyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gr_int_dyn.F	(revision 984)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      subroutine gr_int_dyn(champin,champdyn,iim,jp1)
+      implicit none
+c=======================================================================
+c   passage d'un champ interpole a un champ sur grille scalaire
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER iim
+      integer ip1, jp1
+      REAL champin(iim, jp1)
+      REAL champdyn(iim+1, jp1)
+
+      INTEGER i, j
+      real polenord, polesud
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      ip1 = iim + 1
+      polenord = 0.
+      polesud = 0.
+      do i = 1, iim
+        polenord = polenord + champin (i, 1)
+        polesud = polesud + champin (i, jp1)
+      enddo
+      polenord = polenord / iim
+      polesud = polesud / iim
+      do j = 1, jp1
+        do i = 1, iim
+          if (j .eq. 1) then
+            champdyn(i, j) = polenord
+          else if (j .eq. jp1) then
+            champdyn(i, j) = polesud
+          else
+            champdyn(i, j) = champin (i, j)
+          endif
+        enddo
+        champdyn(ip1, j) = champdyn(1, j)
+      enddo
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gr_u_scal.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gr_u_scal.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gr_u_scal.F	(revision 984)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_u_scal(nx,x_u,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=ip1jmp1,2,-1
+            x_scal(ij,l)=
+     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
+     s      /(aireu(ij)+aireu(ij-1))
+         ENDDO
+      ENDDO
+
+      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gr_v_scal.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gr_v_scal.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gr_v_scal.F	(revision 984)
@@ -0,0 +1,64 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_v_scal(nx,x_v,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=iip2,ip1jm
+            x_scal(ij,l)=
+     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
+     s      /(airev(ij-iip1)+airev(ij))
+         ENDDO
+         DO ij=1,iip1
+            x_scal(ij,l)=0.
+         ENDDO
+         DO ij=ip1jm+1,ip1jmp1
+            x_scal(ij,l)=0.
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/grad.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/grad.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/grad.F	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+      SUBROUTINE  grad(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      INTEGER klevel
+      REAL  pg( ip1jmp1,klevel )
+      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+      INTEGER  l,ij
+c
+c
+      DO 6 l = 1,klevel
+c
+      DO 2  ij = 1, ip1jmp1 - 1
+      pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = iip1, ip1jmp1, iip1
+      pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      DO 4 ij = 1,ip1jm
+      pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gradiv.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gradiv.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gradiv.F	(revision 984)
@@ -0,0 +1,57 @@
+!
+! $Header$
+!
+      SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c    Auteur :   P. Le Van
+c
+c   ***************************************************************
+c
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   ****************************************************************
+c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
+
+      REAL div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+c
+c
+      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+c
+      DO 10 iter = 1,ld
+c
+      CALL  diverg( klevel,  gdx , gdy, div          )
+      CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 )
+      CALL    grad( klevel,  div, gdx, gdy           )
+c
+      DO 5  l = 1, klevel
+      DO 3 ij = 1, ip1jmp1
+      gdx( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+      DO 4 ij = 1, ip1jm
+      gdy( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gradiv2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gradiv2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gradiv2.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c     P. Le Van
+c
+c   **********************************************************
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   **********************************************************
+c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+c
+c     ........    variables en arguments      ........
+
+      INTEGER klevel
+      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL   gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL div(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      
+c    ........................................................
+c
+c
+      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+
+
+      CALL    divergf( klevel, gdx,   gdy , div )
+
+      IF( ld.GT.1 )   THEN
+
+        CALL laplacien ( klevel, div,  div     )
+
+c    ......  Iteration de l'operateur laplacien_gam   .......
+
+        DO iter = 1, ld -2
+         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
+     *                       unsapolnga1, unsapolsga1,  div, div       )
+        ENDDO
+
+      ENDIF
+
+
+       CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
+       CALL  grad  ( klevel,  div,   gdx,  gdy             )
+
+c
+       DO   l = 1, klevel
+         DO  ij = 1, ip1jmp1
+          gdx( ij,l ) = gdx( ij,l ) * nugrads
+         ENDDO
+         DO  ij = 1, ip1jm
+          gdy( ij,l ) = gdy( ij,l ) * nugrads
+         ENDDO
+       ENDDO
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/gradsdef.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/gradsdef.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/gradsdef.h	(revision 984)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+      integer nfmx,imx,jmx,lmx,nvarmx
+      parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000)
+
+      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
+
+      integer imd(imx),jmd(jmx),lmd(lmx)
+      integer iid(imx),jid(jmx)
+      integer ifd(imx),jfd(jmx)
+      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
+
+      integer nvar(nfmx),ivar(nfmx)
+      logical firsttime(nfmx)
+
+      character*10 var(nvarmx,nfmx),fichier(nfmx)
+      character*40 title(nfmx),tvar(nvarmx,nfmx)
+
+      common/gradsdef/xd,yd,zd,dtime,
+     s   imd,jmd,lmd,iid,jid,ifd,jfd,
+     s   unit,irec,nvar,ivar,itime,nld,firsttime,
+     s   var,fichier,title,tvar
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/grid_atob.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/grid_atob.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/grid_atob.F	(revision 984)
@@ -0,0 +1,971 @@
+!
+! $Header$
+!
+      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Aucune ponderation est consideree (voir grille_p)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+      REAL distans(2200*1100)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+c Calculer les limites des zones des nouveaux points
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c Determiner la zone sur laquelle chaque ancien point se trouve
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               number(ii,jj) = number(ii,jj) + 1.0
+               sortie(ii,jj) = sortie(ii,jj) + entree(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c Si aucun ancien point tombe sur une zone, c'est un probleme
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+      SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Consideration de la distance des points (voir grille_m)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(200),d(200)
+      REAL number(400,200)
+      INTEGER indx(400,200), indy(400,200)
+      REAL dist(400,200), distsom(400,200)
+c
+      IF (imar.GT.400 .OR. jmar.GT.200) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+      IF (imdep.GT.400 .OR. jmdep.GT.200) THEN
+         PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep
+         CALL ABORT
+      ENDIF
+c
+c calculer les bords a et b de la nouvelle grille
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+c
+c calculer les bords c et d de la nouvelle grille
+c
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+c
+c trouver les indices (indx,indy) de la nouvelle grille sur laquelle
+c un point de l'ancienne grille est tombe.
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               indx(i,j) = ii
+               indy(i,j) = jj
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c faire une verification
+c
+
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN
+            PRINT*, 'Probleme grave,i,j,indx,indy=',
+     .              i,j,indx(i,j),indy(i,j)
+            CALL abort
+         ENDIF
+      ENDDO
+      ENDDO
+
+c
+c calculer la distance des anciens points avec le nouveau point,
+c on prend ensuite une sorte d'inverse pour ponderation.
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         distsom(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2
+     .                     +(ydata(j)-y(indy(i,j)))**2 )
+         distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j))
+     .                                  + dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1.
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j))
+      ENDDO
+      ENDDO
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j))
+     .                                 + entree(i,j) * dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j))
+     .                                 + dist(i,j)
+      ENDDO
+      ENDDO
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+      SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief,
+     .                    imar, jmar, x, y, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique
+c                           un champ indicateur (masque) terre/ocean
+c                           terre:1; ocean:0
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL relief(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL num_tot(2200,1100), num_oce(2200,1100)
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_oce(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+               IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) )
+     .             num_oce(ii,jj) = num_oce(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+c
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN
+              mask(i,j) = 0.
+           ELSE
+              mask(i,j) = 1.
+           ENDIF
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c
+c
+
+
+      SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une
+c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur
+c fixe (0.001m).
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar), mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_tot(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              sortie(ii,jj)  = sortie(ii,jj) + LOG(entree(i,j))
+              num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+       IF (NINT(mask(i,j)).EQ.1) THEN
+         IF (num_tot(i,j) .GT. 0.0) THEN
+            sortie(i,j) = sortie(i,j) / num_tot(i,j)
+            sortie(i,j) = EXP(sortie(i,j))
+         ELSE
+            PRINT*, 'probleme,i,j=', i,j
+ccc            CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+       ELSE
+         sortie(i,j) = 0.001
+       ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+
+      SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01,
+     .                    imar, jmar, x, y, frac_ice)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la
+c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace
+c (entre 0 et 1) dans une grille plus grossiere.
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL glace01(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL frac_ice(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400), num_ice(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_ice(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+             num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+              IF (NINT(glace01(i,j)).EQ.1 ) 
+     .       num_ice(ii,jj) = num_ice(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF (num_ice(i,j).GT.0.001) THEN
+            frac_ice(i,j) = num_ice(i,j) / num_tot(i,j)
+           ELSE
+              frac_ice(i,j) = 0.0
+           ENDIF
+         ELSE
+           PRINT*, 'probleme,i,j=', i,j
+ccc           CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN
+            frac_ice(i,j) = 1.0
+         ELSE
+            frac_ice(i,j) = 0.0
+         ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+      SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief,
+     .                    immod, jmmod, xmod, ymod, rugs)
+c=======================================================================
+c Calculer la longueur de rugosite liee au relief en utilisant
+c l'ecart-type dans une maille de 1x1
+C=======================================================================
+      IMPLICIT none
+c
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      REAL amin, AMAX
+c
+      INTEGER imrel, jmrel
+      REAL xrel(imrel),yrel(jmrel)
+      REAL relief(imrel,jmrel)
+c
+      INTEGER immod, jmmod
+      REAL xmod(immod),ymod(jmmod)
+      REAL rugs(immod,jmmod)
+c
+      INTEGER imtmp, jmtmp
+      PARAMETER (imtmp=360,jmtmp=180)
+      REAL xtmp(imtmp), ytmp(jmtmp)
+      REAL*8 cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp)
+      REAL zzzz
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+c
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+c
+      IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN
+         PRINT*, 'immod ou jmmod trop grand', immod, jmmod
+         CALL ABORT
+      ENDIF
+c
+c Calculs intermediares:
+c
+      xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0
+      DO i = 2, imtmp
+         xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp)
+      ENDDO
+      DO i = 1, imtmp
+         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+      ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0
+      DO j = 2, jmtmp
+         ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp)
+      ENDDO
+      DO j = 1, jmtmp
+         ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+c
+      a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0
+      b(1) = (xtmp(1)+xtmp(2))/2.0
+      DO i = 2, imtmp-1
+         a(i) = b(i-1)
+         b(i) = (xtmp(i)+xtmp(i+1))/2.0
+      ENDDO
+      a(imtmp) = b(imtmp-1)
+      b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0
+
+      c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0
+      d(1) = (ytmp(1)+ytmp(2))/2.0
+      DO j = 2, jmtmp-1
+         c(j) = d(j-1)
+         d(j) = (ytmp(j)+ytmp(j+1))/2.0
+      ENDDO
+      c(jmtmp) = d(jmtmp-1)
+      d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0
+
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         number(i,j) = 0.0
+         cham1tmp(i,j) = 0.0
+         cham2tmp(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imtmp
+      DO jj = 1, jmtmp
+        DO i = 1, imrel
+         IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmrel
+          IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j)
+              cham2tmp(ii,jj) = cham2tmp(ii,jj) 
+     .                              + relief(i,j)*relief(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         IF (number(i,j) .GT. 0.001) THEN
+         cham1tmp(i,j) = cham1tmp(i,j) / number(i,j)
+         cham2tmp(i,j) = cham2tmp(i,j) / number(i,j)
+         zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2
+         if (zzzz .lt. 0.0) then
+           if (zzzz .gt. -7.5) then
+             zzzz = 0.0
+             print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0'
+           else
+              stop 'Pb rugsoro, zzzz <-7.5'
+           endif
+         endif
+         cham2tmp(i,j) = SQRT(zzzz)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = cham2tmp(1,1)
+      AMAX = cham2tmp(1,1)
+      DO j = 1, jmtmp
+      DO i = 1, imtmp
+         IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j)
+         IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type 1x1:', amin, AMAX
+c
+c
+c
+      a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0
+      b(1) = (xmod(1)+xmod(2))/2.0
+      DO i = 2, immod-1
+         a(i) = b(i-1)
+         b(i) = (xmod(i)+xmod(i+1))/2.0
+      ENDDO
+      a(immod) = b(immod-1)
+      b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0
+
+      c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0
+      d(1) = (ymod(1)+ymod(2))/2.0
+      DO j = 2, jmmod-1
+         c(j) = d(j-1)
+         d(j) = (ymod(j)+ymod(j+1))/2.0
+      ENDDO
+      c(jmmod) = d(jmmod-1)
+      d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         number(i,j) = 0.0
+         rugs(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, immod
+      DO jj = 1, jmmod
+        DO i = 1, imtmp
+         IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmtmp
+          IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              rugs(ii,jj) = rugs(ii,jj)
+     .                       + LOG(MAX(0.001,cham2tmp(i,j)))
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         IF (number(i,j) .GT. 0.001) THEN
+         rugs(i,j) = rugs(i,j) / number(i,j)
+         rugs(i,j) = EXP(rugs(i,j))
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imtmp*jmtmp,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imtmp*jmtmp
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imtmp + 1
+         i_proche = ij_proche - (j_proche-1)*imtmp
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         rugs(i,j) = LOG(MAX(0.001,cham2tmp(i_proche,j_proche)))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type du modele:', amin, AMAX
+c
+      DO j = 1, jmmod
+      DO i = 1, immod
+         rugs(i,j) = rugs(i,j) / AMAX * 20.0
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Longueur de rugosite du modele:', amin, AMAX
+c
+      RETURN
+      END
+c
+      SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance)
+c
+c Auteur: Laurent Li (le 30 decembre 1996)
+c
+c Ce programme calcule la distance minimale (selon le grand cercle)
+c entre deux points sur la terre
+c
+c Input:
+      INTEGER im, jm ! dimensions
+      REAL rf_lon ! longitude du point de reference (degres)
+      REAL rf_lat ! latitude du point de reference (degres)
+      REAL rlon(im), rlat(jm) ! longitude et latitude des points
+c
+c Output:
+      REAL distance(im,jm) ! distances en metre
+c
+      REAL rlon1, rlat1
+      REAL rlon2, rlat2
+      REAL dist
+      REAL pa, pb, p, pi
+c
+      REAL radius
+      PARAMETER (radius=6371229.)
+c
+      pi = 4.0 * ATAN(1.0)
+c
+      DO 9999 j = 1, jm
+      DO 9999 i = 1, im
+c
+      rlon1=rf_lon
+      rlat1=rf_lat
+      rlon2=rlon(i)
+      rlat2=rlat(j)
+      pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a
+      pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b
+      p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens)
+c
+      dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p))
+      dist = radius * dist
+      distance(i,j) = dist
+c
+ 9999 CONTINUE
+c
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/grid_noro.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/grid_noro.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/grid_noro.F	(revision 984)
@@ -0,0 +1,524 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata,
+     .             imar, jmar, x, y,
+     .             zphi,zmea,zstd,zsig,zgam,zthe,
+     .             zpic,zval,mask)
+c=======================================================================
+c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead)
+c
+c      Compute the Parameters of the SSO scheme as described in
+c      LOTT & MILLER (1997) and LOTT(1999).
+c      Target points are on a rectangular grid:
+c      iim+1 latitudes including North and South Poles;
+c      jjm+1 longitudes, with periodicity jjm+1=1.
+c      aux poles.  At the poles the fields value is repeated
+c      jjm+1 time.
+c      The parameters a,b,c,d represent the limite of the target
+c      gridpoint region. The means over this region are calculated
+c      from USN data, ponderated by a weight proportional to the 
+c      surface occupated by the data inside the model gridpoint area.
+c      In most circumstances, this weight is the ratio between the
+c      surface of the USN gridpoint area and the surface of the
+c      model gridpoint area. 
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X and Y input field
+c        xdata, ydata: coordinates X and Y input field
+c        zdata: Input field
+c        In this version it is assumed that the entry data come from
+c        the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080.
+c OUTPUT:
+c        imar, jmar: dimensions X and Y Output field
+c        x, y: ccordinates  X and Y Output field.
+c             zmea:  Mean orographie   
+c             zstd:  Standard deviation
+c             zsig:  Slope
+c             zgam:  Anisotropy
+c             zthe:  Orientation of the small axis
+c             zpic:  Maximum altitude
+c             zval:  Minimum altitude
+C=======================================================================
+
+      IMPLICIT INTEGER (I,J)
+      IMPLICIT REAL(X,Z) 
+      
+	  parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5)
+#include "dimensions.h"
+	  REAL xusn(iusn+2*iext),yusn(jusn+2)	
+      REAL zusn(iusn+2*iext,jusn+2)
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL zdata(imdep,jmdep)
+c
+      INTEGER imar, jmar
+  
+C INTERMEDIATE FIELDS  (CORRELATIONS OF OROGRAPHY GRADIENT)
+
+      REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1)
+      REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1)
+      REAL weight(iim+1,jjm+1)
+
+C CORRELATIONS OF USN OROGRAPHY GRADIENTS
+
+      REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2)
+      REAL zxtzyusn(iusn+2*iext,jusn+2)
+      REAL x(imar+1),y(jmar),zphi(imar+1,jmar)
+      REAL zmea(imar+1,jmar),zstd(imar+1,jmar)
+      REAL zmea0(imar+1,jmar) ! GK211005 (CG)
+      REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar)
+      REAL zpic(imar+1,jmar),zval(imar+1,jmar)
+cx$$ PB     integer mask(imar+1,jmar)
+      real mask(imar+1,jmar), mask_tmp(imar+1,jmar)
+      real num_tot(2200,1100),num_lan(2200,1100)
+c
+      REAL a(2200),b(2200),c(1100),d(1100)
+      logical masque_lu
+c
+      print *,' parametres de l orographie a l echelle sous maille' 
+      xpi=acos(-1.)
+      rad    = 6 371 229.
+      zdeltay=2.*xpi/float(jusn)*rad
+c
+c utilise-t'on un masque lu?
+c
+      masque_lu = .true.
+      if (maxval(mask) == -99999 .and. minval(mask) == -99999) then
+        masque_lu= .false.
+        masque = 0.0
+      endif
+      write(*,*)'Masque lu', masque_lu
+c
+c  quelques tests de dimensions:
+c    
+c
+      if(iim.ne.imar) STOP 'Problem dim. x'
+      if(jjm.ne.jmar-1) STOP 'Problem dim. y'
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar or jmar too big', imar, jmar
+         CALL ABORT
+      ENDIF
+
+      IF(imdep.ne.iusn.or.jmdep.ne.jusn)then
+         print *,' imdep or jmdep bad dimensions:',imdep,jmdep
+         call abort
+      ENDIF
+
+      IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN
+        print *,' imar or jmar bad dimensions:',imar,jmar
+        call abort
+      ENDIF
+
+
+c      print *,'xdata:',xdata
+c      print *,'ydata:',ydata
+c      print *,'x:',x
+c      print *,'y:',y
+c
+C  EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT
+C  BOUNDARIES:
+c
+      DO j=1,jusn
+        yusn(j+1)=ydata(j)
+      DO i=1,iusn
+        zusn(i+iext,j+1)=zdata(i,j)
+        xusn(i+iext)=xdata(i)
+      ENDDO
+      DO i=1,iext
+        zusn(i,j+1)=zdata(iusn-iext+i,j)
+        xusn(i)=xdata(iusn-iext+i)-2.*xpi
+        zusn(iusn+iext+i,j+1)=zdata(i,j)
+        xusn(iusn+iext+i)=xdata(i)+2.*xpi
+      ENDDO
+      ENDDO
+
+        yusn(1)=ydata(1)+(ydata(1)-ydata(2))
+        yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1))
+       DO i=1,iusn/2+iext
+        zusn(i,1)=zusn(i+iusn/2,2)
+        zusn(i+iusn/2+iext,1)=zusn(i,2)
+        zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1)
+        zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1)
+       ENDDO
+c  
+c COMPUTE LIMITS OF MODEL GRIDPOINT AREA
+C     ( REGULAR GRID)
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar+1) = b(imar)
+      b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+c
+c  initialisations:
+c
+      DO i = 1, imar+1
+      DO j = 1, jmar
+         weight(i,j) = 0.0
+         zxtzx(i,j)  = 0.0
+         zytzy(i,j)  = 0.0
+         zxtzy(i,j)  = 0.0
+         ztz(i,j)    = 0.0
+         zmea(i,j)   = 0.0
+         zpic(i,j)  =-1.E+10
+         zval(i,j)  = 1.E+10
+      ENDDO
+      ENDDO
+c
+c  COMPUTE SLOPES CORRELATIONS ON USN GRID
+c
+         DO j = 1,jusn+2 
+         DO i = 1, iusn+2*iext
+            zytzyusn(i,j)=0.0
+            zxtzxusn(i,j)=0.0
+            zxtzyusn(i,j)=0.0
+         ENDDO
+         ENDDO
+
+
+         DO j = 2,jusn+1 
+            zdeltax=zdeltay*cos(yusn(j))
+         DO i = 2, iusn+2*iext-1
+            zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2
+            zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2
+            zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay
+     *                   *(zusn(i+1,j)-zusn(i-1,j))/zdeltax
+         ENDDO
+         ENDDO
+c
+c  SUMMATION OVER GRIDPOINT AREA
+c 
+      zleny=xpi/float(jusn)*rad
+      xincr=xpi/2./float(jusn)
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+       num_tot(ii,jj)=0.
+       num_lan(ii,jj)=0.
+c        PRINT *,' iteration ii jj:',ii,jj
+         DO j = 2,jusn+1 
+c         DO j = 3,jusn 
+            zlenx=zleny*cos(yusn(j))
+            zdeltax=zdeltay*cos(yusn(j))
+            zbordnor=(c(jj)-yusn(j)+xincr)*rad
+            zbordsud=(yusn(j)-d(jj)+xincr)*rad
+            weighy=AMAX1(0.,
+     *             amin1(zbordnor,zbordsud,zleny))
+         IF(weighy.ne.0)THEN
+         DO i = 2, iusn+2*iext-1
+            zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j))
+            zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j))
+            weighx=AMAX1(0.,
+     *             amin1(zbordest,zbordoue,zlenx))
+            IF(weighx.ne.0)THEN
+            num_tot(ii,jj)=num_tot(ii,jj)+1.0
+            if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
+            weight(ii,jj)=weight(ii,jj)+weighx*weighy
+            zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy
+            zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy
+            zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy
+            ztz(ii,jj)  =ztz(ii,jj)  +zusn(i,j)*zusn(i,j)*weighx*weighy
+c mean
+            zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy
+c peacks
+            zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j))
+c valleys
+            zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j))
+            ENDIF
+         ENDDO
+         ENDIF
+         ENDDO
+       ENDDO
+       ENDDO
+c
+c  COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND
+C  LOTT (1999) SSO SCHEME.
+c
+      zllmmea=0.
+      zllmstd=0.
+      zllmsig=0.
+      zllmgam=0.
+      zllmpic=0.
+      zllmval=0.
+      zllmthe=0.
+      zminthe=0.
+c     print 100,' '
+c100  format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') 
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Mask
+cx$$           if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then
+cx$$             mask(ii,jj)=1
+cx$$           else
+cx$$             mask(ii,jj)=0
+cx$$           ENDIF
+             if (.not. masque_lu) then
+               mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj)
+             endif
+c  Mean Orography:
+           zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj)
+           zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj)
+           zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj)
+           zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj)
+           ztz(ii,jj)  =ztz(ii,jj)/weight(ii,jj)
+c  Standard deviation:
+           zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2))
+         ELSE
+            PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+       ENDDO
+       ENDDO
+
+C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES:
+
+       DO ii = 1, imar+1
+         zxtzx(ii,1)=zxtzx(ii,2)
+         zxtzx(ii,jmar)=zxtzx(ii,jmar-1)
+         zxtzy(ii,1)=zxtzy(ii,2)
+         zxtzy(ii,jmar)=zxtzy(ii,jmar-1)
+         zytzy(ii,1)=zytzy(ii,2)
+         zytzy(ii,jmar)=zytzy(ii,jmar-1)
+       ENDDO
+
+C  FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME.
+
+C  FIRST FILTER, MOVING AVERAGE OVER 9 POINTS.
+
+       zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee
+       CALL MVA9(zmea,iim+1,jjm+1)
+       CALL MVA9(zstd,iim+1,jjm+1)
+       CALL MVA9(zpic,iim+1,jjm+1)
+       CALL MVA9(zval,iim+1,jjm+1)
+       CALL MVA9(zxtzx,iim+1,jjm+1)
+       CALL MVA9(zxtzy,iim+1,jjm+1) 
+       CALL MVA9(zytzy,iim+1,jjm+1)
+Cx$$   Masque prenant en compte maximum de terre
+Cx$$  On seuil a 10% de terre de terre car en dessous les parametres de surface n'on
+Cx$$ pas de sens (PB)
+       mask_tmp= 0.0
+       WHERE(mask .GE. 0.1) mask_tmp = 1.
+
+       DO ii = 1, imar
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Coefficients K, L et M:
+           xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2.
+           xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2.
+           xm=zxtzy(ii,jj)
+           xp=xk-sqrt(xl**2+xm**2)
+           xq=xk+sqrt(xl**2+xm**2)
+           xw=1.e-8
+           if(xp.le.xw) xp=0.
+           if(xq.le.xw) xq=xw
+           if(abs(xm).le.xw) xm=xw*sign(1.,xm)
+c slope: 
+cx$$           zsig(ii,jj)=sqrt(xq)*mask(ii,jj)
+cx$$c isotropy:
+cx$$           zgam(ii,jj)=xp/xq*mask(ii,jj)
+cx$$c angle theta:
+cx$$           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj)
+cx$$           zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+cx$$           zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+cx$$           zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj)
+cx$$           zval(ii,jj)=zval(ii,jj)*mask(ii,jj)
+cx$$           zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj)
+Cx$* PB modif pour maque de terre fractionnaire
+c slope: 
+           zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj)
+c isotropy:
+           zgam(ii,jj)=xp/xq*mask_tmp(ii,jj)
+c angle theta:
+           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj)
+           ! GK211005 (CG) ne pas forcement lisser la topo
+           ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj)
+           !
+           zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj)
+           zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj)
+           zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj)
+c          print 101,ii,jj,
+c    *           zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj),
+c    *           zthe(ii,jj)
+c101  format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1)     
+         ELSE
+c           PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+      zllmmea=AMAX1(zmea(ii,jj),zllmmea)
+      zllmstd=AMAX1(zstd(ii,jj),zllmstd)
+      zllmsig=AMAX1(zsig(ii,jj),zllmsig)
+      zllmgam=AMAX1(zgam(ii,jj),zllmgam)
+      zllmthe=AMAX1(zthe(ii,jj),zllmthe)
+      zminthe=amin1(zthe(ii,jj),zminthe)
+      zllmpic=AMAX1(zpic(ii,jj),zllmpic)
+      zllmval=AMAX1(zval(ii,jj),zllmval)
+       ENDDO
+       ENDDO
+      print *,'  MEAN ORO:',zllmmea
+      print *,'  ST. DEV.:',zllmstd
+      print *,'  PENTE:',zllmsig
+      print *,' ANISOTROP:',zllmgam
+      print *,'  ANGLE:',zminthe,zllmthe	
+      print *,'  pic:',zllmpic
+      print *,'  val:',zllmval
+      
+C
+c gamma and theta a 1. and 0. at poles
+c
+      DO jj=1,jmar
+      zmea(imar+1,jj)=zmea(1,jj)
+      zphi(imar+1,jj)=zphi(1,jj)
+      zpic(imar+1,jj)=zpic(1,jj)
+      zval(imar+1,jj)=zval(1,jj)
+      zstd(imar+1,jj)=zstd(1,jj)
+      zsig(imar+1,jj)=zsig(1,jj)
+      zgam(imar+1,jj)=zgam(1,jj)
+      zthe(imar+1,jj)=zthe(1,jj)
+      ENDDO
+
+
+      zmeanor=0.0
+      zmeasud=0.0
+      zstdnor=0.0
+      zstdsud=0.0
+      zsignor=0.0
+      zsigsud=0.0
+      zweinor=0.0
+      zweisud=0.0
+      zpicnor=0.0
+      zpicsud=0.0                                   
+      zvalnor=0.0
+      zvalsud=0.0 
+
+      DO ii=1,imar
+      zweinor=zweinor+              weight(ii,   1)
+      zweisud=zweisud+              weight(ii,jmar)
+      zmeanor=zmeanor+zmea(ii,   1)*weight(ii,   1)
+      zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar)
+      zstdnor=zstdnor+zstd(ii,   1)*weight(ii,   1)
+      zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar)
+      zsignor=zsignor+zsig(ii,   1)*weight(ii,   1)
+      zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar)
+      zpicnor=zpicnor+zpic(ii,   1)*weight(ii,   1)
+      zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar)
+      zvalnor=zvalnor+zval(ii,   1)*weight(ii,   1)
+      zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar)
+      ENDDO
+
+      DO ii=1,imar+1
+      zmea(ii,   1)=zmeanor/zweinor
+      zmea(ii,jmar)=zmeasud/zweisud
+      zphi(ii,   1)=zmeanor/zweinor
+      zphi(ii,jmar)=zmeasud/zweisud
+      zpic(ii,   1)=zpicnor/zweinor
+      zpic(ii,jmar)=zpicsud/zweisud
+      zval(ii,   1)=zvalnor/zweinor
+      zval(ii,jmar)=zvalsud/zweisud
+      zstd(ii,   1)=zstdnor/zweinor
+      zstd(ii,jmar)=zstdsud/zweisud
+      zsig(ii,   1)=zsignor/zweinor
+      zsig(ii,jmar)=zsigsud/zweisud
+      zgam(ii,   1)=1.
+      zgam(ii,jmar)=1.
+      zthe(ii,   1)=0.
+      zthe(ii,jmar)=0.
+      ENDDO
+
+      RETURN
+      END
+
+      SUBROUTINE MVA9(X,IMAR,JMAR)
+
+C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
+
+      PARAMETER (ISMo=400,JSMo=200)
+      REAL X(IMAR,JMAR),XF(ISMo,JSMo)
+      real WEIGHTpb(-1:1,-1:1)
+
+      if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)'
+      if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)'
+      
+      SUM=0.
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
+          SUM=SUM+WEIGHTpb(IS,JS)
+        ENDDO
+      ENDDO
+      
+c     WRITE(*,*) 'MVA9 ', IMAR, JMAR
+c     WRITE(*,*) 'MVA9 ', WEIGHTpb
+c     WRITE(*,*) 'MVA9 SUM ', SUM
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        DO I=2,IMAR-1
+          XF(I,J)=0.
+          DO IS=-1,1
+            DO JS=-1,1
+              XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS)
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        XF(1,J)=0.
+        IS=IMAR-1
+        DO JS=-1,1 
+          XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS)
+        ENDDO
+        DO IS=0,1 
+          DO JS=-1,1 
+            XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS)
+          ENDDO
+        ENDDO
+        XF(IMAR,J)=XF(1,J)
+      ENDDO
+
+      DO I=1,IMAR
+        XF(I,1)=XF(I,2)
+        XF(I,JMAR)=XF(I,JMAR-1)
+      ENDDO
+
+      DO I=1,IMAR
+        DO J=1,JMAR
+          X(I,J)=XF(I,J)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/grilles_gcm_netcdf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/grilles_gcm_netcdf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/grilles_gcm_netcdf.F	(revision 984)
@@ -0,0 +1,305 @@
+!
+! $Header$
+!
+c
+c
+
+      PROGRAM create_fausse_var
+C
+      IMPLICIT NONE
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+
+      real temp(iim+1,jjm+1)
+#include "netcdf.inc"
+
+c Attributs netcdf sortie
+        character*64 fich_out
+        integer*4 ncid_out,rcode_out
+        integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid
+        integer*4 out_varid
+        integer*4 out_lonudim,out_lonvdim
+        integer*4 out_latudim,out_latvdim,out_dim(3)
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      integer start(4),count(4)
+
+	integer status,i,j
+        real rlatudeg(jjp1),rlatvdeg(jjm)
+        real rlonudeg(iip1),rlonvdeg(iip1)
+
+      real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
+      real acoslat,dxkm,dykm,resol(iip1,jjp1)
+
+#include "serre.h"
+#include "fxyprim.h"
+
+      print*,'OK0'
+
+      rad = 6400000
+      omeg = 7.272205e-05
+      g = 9.8
+      kappa = 0.285716
+      daysec = 86400
+      cpp = 1004.70885
+
+      preff = 101325.
+      pa= 50000.
+
+c     open(99,file='run.def',status='old',form='formatted')
+c     CALL defrun_new( 99, .TRUE.,clesphy0 )
+c     close(99)
+
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+      CALL iniconst
+      CALL inigeom
+
+
+      print*,'OK1'
+      do j=1,jjp1
+         rlatudeg(j)=rlatu(j)*180./pi
+      enddo
+      do j=1,jjm
+         rlatvdeg(j)=rlatv(j)*180./pi
+      enddo
+
+      do i=1,iip1
+         rlonudeg(i)=rlonu(i)*180./pi + 360.
+         rlonvdeg(i)=rlonv(i)*180./pi + 360.
+      enddo
+
+
+      print*,'OK2'
+c  2 ----- OUVERTURE DE LA SORTIE NETCDF
+c ---------------------------------------------------
+c CREATION OUTPUT
+c ouverture fichier netcdf de sortie out
+        fich_out='grilles_gcm.nc'
+
+        status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out)
+        status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
+        status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
+        status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
+        status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
+
+
+      print*,'OK3'
+c   Longitudes en u
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim,
+     %  out_lonuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',
+     %  9,'Longitude en u')
+
+c   Longitudes en v
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim,
+     %  out_lonvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name',
+     %  9,'Longitude en v')
+
+c   Latitude en u
+        status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim,
+     %  out_latuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name',
+     %  8,'Latitude en u')
+
+c  Latitude en v
+        status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim,
+     %  out_latvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name',
+     %  8,'Latitude en v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonudim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+c   ecriture de la grille v
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latvdim
+        status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+
+      print*,'OK4'
+        status=NF_ENDDEF(ncid_out)
+c 5) ----- FERMETURE DES FICHIERS NETCDF------------------
+c --------------------------------------------------------
+c 3-b- Ecriture de la grille pour la sortie
+c rajoute l'ecriture de la grille
+
+#ifdef NC_DOUBLE
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#else
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#endif
+
+        start(1)=1
+        start(2)=1
+        start(3)=1
+        start(4)=1
+
+        count(1)=iim+1
+        count(2)=jjm+1
+        count(3)=1
+        count(4)=1
+
+        do j=1,jjm+1
+           do i=1,iim+1
+              temp(i,j)=mod(i,2)+mod(j,2)
+           enddo
+        enddo
+
+#ifdef NC_DOUBLE
+        status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start,
+     s  count,temp)
+#else
+        status=NF_PUT_VARA_REAL(ncid_out,out_varid,start,
+     s  count,temp)
+#endif
+
+
+c fermeture du fichier netcdf
+        call ncclos(ncid_out,rcode_out)
+        write(*,*) 'Fermeture: ',fich_out
+
+
+      print*,'OK5'
+c   Ecriture grads
+      open (20,file='grille.dat',form='unformatted',access='direct'
+     s      ,recl=4*ip1jmp1)
+      write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
+      write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
+      do j=2,jjm
+         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
+c        dlat2(j)=180.*fyprim(float(j))/pi
+      enddo
+      do i=2,iip1
+         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
+c        dlon2(i)=180.*fxprim(float(i))/pi
+      enddo
+      do j=2,jjm
+         dykm=(rlatv(j)-rlatv(j-1))*6400.
+         acoslat=6400.*cos(rlatu(j))
+         do i=2,iip1
+            dxkm=acoslat*(rlonu(i)-rlonu(i-1))
+            resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm)
+         enddo
+         resol(1,j)=resol(iip1,j)
+      enddo
+      write(20,rec=3) resol
+      dlon1(1)=dlon1(iip1)
+      dlon2(1)=dlon2(iip1)
+      write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=5) ((dlon1(i)*pi/180.*0.001*
+     s   cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1)
+      write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1)
+      write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1)
+      write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1)
+
+      print*,'I, LON, DX (km)'
+      do i=1,iip1
+         print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001*
+     s   cos(clat*pi/180.)*rad
+      enddo
+      print*,'J, LAT, DY (km)'
+      do j=1,jjp1
+         print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad
+      enddo
+
+      open (21,file='grille.ctl',form='formatted')
+
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      write(21,'(a5,1x,a40)')
+     &       'DSET ','^grille.dat'
+
+      write(21,'(a12)') 'UNDEF 1.0E30'
+      write(21,'(a5,1x,a40)') 'TITLE ','grille'
+      call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF')
+      call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF')
+      call formcoord(21,1,0.,1.,.false.,'ZDEF')
+      write(21,'(a4,i10,a30)')
+     &       'TDEF ',1,' LINEAR 23OCT1994 3hr '
+      write(21,'(a4,2x,i5)') 'VARS',9
+      write(21,'(a18)') 'grille 0 99 grille'
+      write(21,'(a18)') 'gril   0 99 gril  '
+      write(21,'(a29)') 'resol   0 99 resolution (km)  '
+      write(21,'(a18)') 'dlon1  0 99 dlon1 '
+      write(21,'(a20)') 'dx     0 99 dx (km) '
+      write(21,'(a18)') 'dlon2  0 99 dlon2 '
+      write(21,'(a18)') 'dlat1  0 99 dlat1 '
+      write(21,'(a20)') 'dy     0 99 dy (km) '
+      write(21,'(a18)') 'dlat2  0 99 dlat2 '
+      write(21,'(a7)') 'ENDVARS'
+
+
+
+
+
+      print*,'OK6'
+	end
+
+
+
+        subroutine handle_err(status)
+#include "netcdf.inc"
+
+
+        integer status
+        print *,'handle code err: ',NF_NOERR
+        IF (status.NE.nf_noerr) THEN
+                print *,NF_STRERROR(status)
+                stop 'stopped'
+        ENDIF
+        END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/groupe.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/groupe.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/groupe.F	(revision 984)
@@ -0,0 +1,97 @@
+!
+! $Header$
+!
+      subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      implicit none
+
+c   sous-programme servant a fitlrer les champs de flux de masse aux
+c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+c   et a mesure qu'on se rapproche du pole.
+c
+c   en entree: pext, pbaru et pbarv
+c
+c   en sortie:  pbarum,pbarvm et wm.
+c
+c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+c   pas besoin de w en entree.
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "comvert.h"
+
+      integer ngroup
+      parameter (ngroup=3)
+
+
+      real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
+      real pext(iip1,jjp1,llm)
+
+      real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
+      real wm(iip1,jjp1,llm)
+
+      real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm)
+
+      real uu
+
+      integer i,j,l
+
+      logical firstcall
+      save firstcall
+
+      data firstcall/.true./
+
+      if (firstcall) then
+         if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point'
+         firstcall=.false.
+      endif
+
+c   Champs 1D
+
+      call convflu(pbaru,pbarv,llm,zconvm)
+
+c
+      call scopy(ijp1llm,zconvm,1,zconvmm,1)
+      call scopy(ijmllm,pbarv,1,pbarvm,1)
+
+c
+      call groupeun(jjp1,llm,zconvmm)
+      call groupeun(jjm,llm,pbarvm)
+
+c   Champs 3D
+
+      do l=1,llm
+         do j=2,jjm
+            uu=pbaru(iim,j,l)
+            do i=1,iim
+               uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+               pbarum(i,j,l)=uu
+c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+c    *                      yflu(i,j,l)-yflu(i,j-1,l)
+            enddo
+            pbarum(iip1,j,l)=pbarum(1,j,l)
+         enddo
+      enddo
+
+c    integration de la convergence de masse de haut  en bas ......
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iip1
+               zconvmm(i,j,l)=zconvmm(i,j,l)
+            enddo
+         enddo
+      enddo
+      do  l = llm-1,1,-1
+          do j=1,jjp1
+             do i=1,iip1
+                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+             enddo
+          enddo
+      enddo
+
+      CALL vitvert(zconvmm,wm)
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/groupeun.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/groupeun.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/groupeun.F	(revision 984)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+      subroutine groupeun(jjmax,llmax,q)
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      integer jjmax,llmax
+      real q(iip1,jjmax,llmax)
+
+      integer ngroup
+      parameter (ngroup=3)
+
+      real airen,airecn,qn
+      real aires,airecs,qs
+
+      integer i,j,l,ig,j1,j2,i0,jd
+
+Champs 3D
+      jd=jjp1-jjmax
+      do l=1,llm
+      j1=1+jd
+      j2=2
+      do ig=1,ngroup
+         do j=j1-jd,j2-jd
+c           print*,'groupe ',ig,'  j= ',j,2**(ngroup-ig+1),'pts groupes'
+            do i0=1,iim,2**(ngroup-ig+1)
+               airen=0.
+               airecn=0.
+               qn=0.
+               aires=0.
+               airecs=0.
+               qs=0.
+               do i=i0,i0+2**(ngroup-ig+1)-1
+                  airen=airen+aire(i,j)
+                  aires=aires+aire(i,jjp1-j+1)
+                  qn=qn+q(i,j,l)
+                  qs=qs+q(i,jjp1-j+1-jd,l)
+               enddo
+               airecn=0.
+               airecs=0.
+               do i=i0,i0+2**(ngroup-ig+1)-1
+                  q(i,j,l)=qn*aire(i,j)/airen
+                  q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires
+               enddo
+            enddo
+            q(iip1,j,l)=q(1,j,l)
+            q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
+         enddo
+         j1=j2+1
+         j2=j2+2**ig
+      enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/guide.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/guide.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/guide.F	(revision 984)
@@ -0,0 +1,517 @@
+!
+! $Header$
+!
+      subroutine guide(itau,ucov,vcov,teta,q,masse,ps)
+
+      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:  F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+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 shema de Van-leer pour l'advection de
+c         q  , en faisant iadv = 10  dans   traceur  (29/04/97) .
+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 "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "tracstoke.h"
+#include "guide.h"
+
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+
+c   common passe pour des sorties
+      real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm)
+      common/comdxdy/dxdys,dxdyu,dxdyv
+
+c   variables dynamiques pour les reanalyses.
+      REAL ucovrea1(ip1jmp1,llm),vcovrea1(ip1jm,llm) !vts cov reas
+      REAL tetarea1(ip1jmp1,llm)             ! temp pot  reales
+      REAL qrea1(ip1jmp1,llm)             ! temp pot  reales
+      REAL masserea1(ip1jmp1,llm)             ! masse
+      REAL psrea1(ip1jmp1)             ! ps
+      REAL ucovrea2(ip1jmp1,llm),vcovrea2(ip1jm,llm) !vts cov reas
+      REAL tetarea2(ip1jmp1,llm)             ! temp pot  reales
+      REAL qrea2(ip1jmp1,llm)             ! temp pot  reales
+      REAL masserea2(ip1jmp1,llm)             ! masse
+      REAL psrea2(ip1jmp1)             ! ps
+      real latmin
+
+      real alpha_q(ip1jmp1)
+      real alpha_T(ip1jmp1),alpha_P(ip1jmp1)
+      real alpha_u(ip1jmp1),alpha_v(ip1jm)
+      real dday_step,toto,reste,itau_test
+      INTEGER step_rea,count_no_rea
+
+cIM 180305   real aire_min,aire_max
+      integer ilon,ilat
+      real factt,ztau(ip1jmp1)
+
+      INTEGER itau,ij,l,i,j
+      integer ncidpl,varidpl,nlev,status
+      integer rcod,rid 
+      real ditau,tau,a
+      save nlev
+
+c  TEST SUR QSAT
+      real p(ip1jmp1,llmp1),pk(ip1jmp1,llm),pks(ip1jmp1)
+      real pkf(ip1jmp1,llm)
+      real pres(ip1jmp1,llm)
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+
+      real qsat(ip1jmp1,llm)
+      real unskap
+      real tnat(ip1jmp1,llm)
+ccccccccccccccccc
+
+
+      LOGICAL first
+      save first
+      data first/.true./
+
+      save ucovrea1,vcovrea1,tetarea1,masserea1,psrea1,qrea1
+      save ucovrea2,vcovrea2,tetarea2,masserea2,psrea2,qrea2
+
+      save alpha_T,alpha_q,alpha_u,alpha_v,alpha_P,itau_test
+      save step_rea,count_no_rea
+
+      character*10 file
+      integer igrads
+      real dtgrads
+      save igrads,dtgrads
+      data igrads,dtgrads/2,100./
+
+C-----------------------------------------------------------------------
+c calcul de l'humidite saturante
+C-----------------------------------------------------------------------
+c     print*,'OK0'
+      CALL pression( ip1jmp1, ap, bp, ps, p )
+      call massdair(p,masse)
+c     print*,'OK1'
+      CALL exner_hyb(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
+c     print*,'OK2'
+      tnat(:,:)=pk(:,:)*teta(:,:)/cpp
+c     print*,'OK3'
+      unskap   = 1./ kappa
+      pres(:,:)=preff*(pk(:,:)/cpp)**unskap
+c     print*,'OK4'
+      call q_sat(iip1*jjp1*llm,tnat,pres,qsat)
+
+C-----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c   initialisations pour la lecture des reanalyses.
+c    alpha determine la part des injections de donnees a chaque etape
+c    alpha=1 signifie pas d'injection
+c    alpha=0 signifie injection totale
+c-----------------------------------------------------------------------
+
+c     print*,'ONLINE=',online
+      if(online.eq.-1) then
+          return
+      endif
+
+      if (first) then
+
+         print*,'initialisation du guide '
+         call conf_guide
+         print*,'apres conf_guide'
+
+         file='guide'
+         call inigrads(igrads,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtgrads,file,'dyn_zon ')
+
+         print*
+     s   ,'1: en-ligne, 0: hors-ligne (x=x_rea), -1: climat (x=x_gcm)'
+
+         if(online.eq.-1) return
+         if (online.eq.1) then
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c  Constantes de temps de rappel en jour
+c  0.1 c'est en gros 2h30. 
+c  1e10  est une constante infinie donc en gros pas de guidage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   coordonnees du centre du zoom
+           call coordij(clon,clat,ilon,ilat)
+c   aire de la maille au centre du zoom
+           aire_min=aire(ilon+(ilat-1)*iip1)
+c   aire maximale de la maille
+           aire_max=0.
+           do ij=1,ip1jmp1
+              aire_max=max(aire_max,aire(ij))
+           enddo
+C  factt = pas de temps en fraction de jour
+           factt=dtvr*iperiod/daysec
+
+c     subroutine tau2alpha(type,im,jm,factt,taumin,taumax,alpha)
+           call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+           call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+           call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+           call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+           call tau2alpha(1,iip1,jjp1,factt,tau_min_q,tau_max_q,alpha_q)
+
+           call dump2d(iip1,jjp1,aire,'AIRE MAILLe ')
+           call dump2d(iip1,jjp1,alpha_u,'COEFF U   ')
+           call dump2d(iip1,jjp1,alpha_T,'COEFF T   ')
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   Cas ou on force exactement par les variables analysees
+         else
+            alpha_T=0.
+            alpha_u=0.
+            alpha_v=0.
+            alpha_P=0.
+c           physic=.false.
+         endif
+
+         itau_test=1001
+         step_rea=1
+         count_no_rea=0
+         ncidpl=-99
+
+c    itau_test    montre si l'importation a deja ete faite au rang itau
+c lecture d'un fichier netcdf pour determiner le nombre de niveaux
+         if (guide_u) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('u.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (guide_v) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('v.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (guide_T) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('T.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (guide_Q) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('hur.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (ncep) then
+          status=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+         else
+          status=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+         endif
+          status=NF_INQ_DIMLEN(ncidpl,rid,nlev)
+         print *,'nlev', nlev 
+          call ncclos(ncidpl,rcod)
+c   Lecture du premier etat des reanalyses.
+         call read_reanalyse(1,ps
+     s   ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev)
+         qrea2(:,:)=max(qrea2(:,:),0.1)
+
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+
+      endif ! first
+c
+C-----------------------------------------------------------------------
+C----- IMPORTATION DES VENTS,PRESSION ET TEMPERATURE REELS:
+C-----------------------------------------------------------------------
+
+      ditau=real(itau)
+      DDAY_step=real(day_step)
+      write(*,*)'ditau,dday_step'
+      write(*,*)ditau,dday_step
+      toto=4*ditau/dday_step
+      reste=toto-aint(toto)
+c     write(*,*)'toto,reste',toto,reste
+
+      if (reste.eq.0.) then
+        if (itau_test.eq.itau) then
+          write(*,*)'deuxieme passage de advreel a itau=',itau
+          stop
+        else
+        vcovrea1(:,:)=vcovrea2(:,:)
+        ucovrea1(:,:)=ucovrea2(:,:)
+        tetarea1(:,:)=tetarea2(:,:)
+        qrea1(:,:)=qrea2(:,:)
+
+          print*,'LECTURE REANALYSES, pas ',step_rea
+     s         ,'apres ',count_no_rea,' non lectures'
+           step_rea=step_rea+1
+           itau_test=itau
+           call read_reanalyse(step_rea,ps
+     s     ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev)
+         qrea2(:,:)=max(qrea2(:,:),0.1)
+      factt=dtvr*iperiod/daysec
+      ztau(:)=factt/max(alpha_T(:),1.e-10)
+      call wrgrads(igrads,1,aire   ,'aire      ','aire      ' )
+      call wrgrads(igrads,1,dxdys  ,'dxdy      ','dxdy      ' )
+      call wrgrads(igrads,1,alpha_u,'au        ','au        ' )
+      call wrgrads(igrads,1,alpha_T,'at        ','at        ' )
+      call wrgrads(igrads,1,ztau,'taut      ','taut      ' )
+      call wrgrads(igrads,llm,ucov,'u         ','u         ' )
+      call wrgrads(igrads,llm,ucovrea2,'ua        ','ua        ' )
+      call wrgrads(igrads,llm,teta,'T         ','T         ' )
+      call wrgrads(igrads,llm,tetarea2,'Ta        ','Ta        ' )
+      call wrgrads(igrads,llm,qrea2,'Qa        ','Qa        ' )
+      call wrgrads(igrads,llm,q,'Q         ','Q         ' )
+
+      call wrgrads(igrads,llm,qsat,'QSAT      ','QSAT      ' )
+
+        endif
+      else
+        count_no_rea=count_no_rea+1
+      endif
+ 
+C-----------------------------------------------------------------------
+c   Guidage
+c    x_gcm = a * x_gcm + (1-a) * x_reanalyses
+C-----------------------------------------------------------------------
+
+       if(ini_anal) print*,'ATTENTION !!! ON PART DU GUIDAGE'
+
+      ditau=real(itau)
+      dday_step=real(day_step)
+
+
+      tau=4*ditau/dday_step
+      tau=tau-aint(tau)
+
+c  ucov
+      if (guide_u) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+                a=(1.-tau)*ucovrea1(ij,l)+tau*ucovrea2(ij,l)
+                ucov(ij,l)=(1.-alpha_u(ij))*ucov(ij,l)+alpha_u(ij)*a
+                if (first.and.ini_anal) ucov(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c  teta
+      if (guide_T) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+                a=(1.-tau)*tetarea1(ij,l)+tau*tetarea2(ij,l)
+                teta(ij,l)=(1.-alpha_T(ij))*teta(ij,l)+alpha_T(ij)*a
+                if (first.and.ini_anal) teta(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c  P
+      if (guide_P) then
+         do ij=1,ip1jmp1
+             a=(1.-tau)*psrea1(ij)+tau*psrea2(ij)
+             ps(ij)=(1.-alpha_P(ij))*ps(ij)+alpha_P(ij)*a
+             if (first.and.ini_anal) ps(ij)=a
+         enddo
+         CALL pression(ip1jmp1,ap,bp,ps,p)
+         CALL massdair(p,masse)
+      endif
+
+
+c  q
+      if (guide_Q) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+                a=(1.-tau)*qrea1(ij,l)+tau*qrea2(ij,l)
+c   hum relative en % -> hum specif
+                a=qsat(ij,l)*a*0.01
+                q(ij,l)=(1.-alpha_Q(ij))*q(ij,l)+alpha_Q(ij)*a
+                if (first.and.ini_anal) q(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c vcov
+      if (guide_v) then
+         do l=1,llm
+            do ij=1,ip1jm
+                a=(1.-tau)*vcovrea1(ij,l)+tau*vcovrea2(ij,l)
+                vcov(ij,l)=(1.-alpha_v(ij))*vcov(ij,l)+alpha_v(ij)*a
+                if (first.and.ini_anal) vcov(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c     call dump2d(iip1,jjp1,tetarea1,'TETA REA 1     ')
+c     call dump2d(iip1,jjp1,tetarea2,'TETA REA 2     ')
+c     call dump2d(iip1,jjp1,teta,'TETA           ')
+
+         first=.false.
+
+      return
+      end
+
+c=======================================================================
+      subroutine tau2alpha(type,pim,pjm,factt,taumin,taumax,alpha)
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "guide.h"
+#include "serre.h"
+
+c   arguments :
+      integer type
+      integer pim,pjm
+      real factt,taumin,taumax,dxdymin,dxdymax
+      real dxdy_,alpha(pim,pjm)
+      real dxdy_min,dxdy_max
+
+c  local :
+      real alphamin,alphamax,gamma,xi
+      save gamma
+      integer i,j,ilon,ilat
+
+      logical first
+      save first
+      data first/.true./
+
+      real cus(iip1,jjp1),cvs(iip1,jjp1)
+      real cuv(iip1,jjm),cvu(iip1,jjp1)
+      real zdx(iip1,jjp1),zdy(iip1,jjp1)
+
+      real zlat
+      real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm)
+      common/comdxdy/dxdys,dxdyu,dxdyv
+
+      if (first) then
+         do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+         enddo
+         do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+         enddo
+         do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+         enddo
+         do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+         enddo
+         do j=1,jjp1
+            do i=1,iim
+               dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+            enddo
+            dxdyu(iip1,j)=dxdyu(1,j)
+         enddo
+         do j=1,jjm
+            do i=1,iip1
+               dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+            enddo
+         enddo
+
+         call dump2d(iip1,jjp1,dxdys,'DX2DY2 SCAL  ')
+         call dump2d(iip1,jjp1,dxdyu,'DX2DY2 U     ')
+         call dump2d(iip1,jjp1,dxdyv,'DX2DY2 v     ')
+
+c   coordonnees du centre du zoom
+           call coordij(clon,clat,ilon,ilat)
+c   aire de la maille au centre du zoom
+           dxdy_min=dxdys(ilon,ilat)
+c   dxdy maximale de la maille
+           dxdy_max=0.
+           do j=1,jjp1
+              do i=1,iip1
+                 dxdy_max=max(dxdy_max,dxdys(i,j))
+              enddo
+           enddo
+
+         if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+             print*,'ATTENTION modele peu zoome'
+             print*,'ATTENTION on prend une constante de guidage cste'
+             gamma=0.
+         else
+            gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+            print*,'gamma=',gamma
+            if (gamma.lt.1.e-5) then
+              print*,'gamma =',gamma,'<1e-5'
+              stop
+            endif
+            print*,'gamma=',gamma
+            gamma=log(0.5)/log(gamma)
+         endif
+      endif
+
+      alphamin=factt/taumax
+      alphamax=factt/taumin
+
+      do j=1,pjm
+         do i=1,pim
+            if (type.eq.1) then
+               dxdy_=dxdys(i,j)
+               zlat=rlatu(j)*180./pi
+            elseif (type.eq.2) then
+               dxdy_=dxdyu(i,j)
+               zlat=rlatu(j)*180./pi
+            elseif (type.eq.3) then
+               dxdy_=dxdyv(i,j)
+               zlat=rlatv(j)*180./pi
+            endif
+         if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+c  pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+             alpha(i,j)=alphamin
+         else
+            xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+            xi=min(xi,1.)
+            if(lat_min_guide.le.zlat .and. zlat.le.lat_max_guide) then
+               alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+            else
+               alpha(i,j)=0.
+            endif
+         endif
+         enddo
+      enddo
+
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/guide.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/guide.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/guide.h	(revision 984)
@@ -0,0 +1,39 @@
+!
+! $Header$
+!
+      real tau_min_u,tau_max_u
+      real tau_min_v,tau_max_v
+      real tau_min_T,tau_max_T
+      real tau_min_q,tau_max_q
+      real tau_min_P,tau_max_P
+      real aire_min,aire_max
+
+
+      logical guide_u,guide_v,guide_T,guide_Q,guide_P
+
+      real lat_min_guide,lat_max_guide
+
+
+c     data tau_min_u,tau_max_u/0.02,10./
+c     data tau_min_v,tau_max_v/0.02,10./
+c     data tau_min_T,tau_max_T/0.02,10./
+c     data tau_min_q,tau_max_q/0.02,10./
+c     data tau_min_P,tau_max_P/0.02,10./
+c
+      LOGICAL ncep,ini_anal
+      integer online
+
+c     data online/1/
+c     data ncep,ini_anal/.false.,.true./
+
+      common/comguide/
+     s tau_min_u,tau_max_u,
+     s tau_min_v,tau_max_v,
+     s tau_min_T,tau_max_T,
+     s tau_min_q,tau_max_q,
+     s tau_min_P,tau_max_P,
+     s aire_min,aire_max,
+     s lat_min_guide,lat_max_guide,
+     s ncep,ini_anal,
+     s online,
+     s guide_u,guide_v,guide_T,guide_Q,guide_P
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/heavyside.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/heavyside.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/heavyside.F	(revision 984)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+c
+c
+       FUNCTION heavyside(a)
+
+c      ...   P. Le Van  ....
+c
+       IMPLICIT NONE
+
+       REAL*8 heavyside , a
+
+       IF ( a.LE.0. )  THEN
+         heavyside = 0.
+       ELSE
+         heavyside = 1.
+       ENDIF
+
+       RETURN
+       END
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ini_paramLMDZ_dyn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ini_paramLMDZ_dyn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ini_paramLMDZ_dyn.h	(revision 984)
@@ -0,0 +1,214 @@
+c
+      dt_cum = dtvr*day_step
+
+      zan = annee_ref
+      dayref = day_ref
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+c
+       pi = 4.0 * ATAN(1.0)
+       degres = 180./pi
+       rlong = rlonu * degres
+       rlatg = rlatu * degres
+c
+      CALL histbeg("paramLMDZ_dyn.nc", 
+     .                 iip1,rlong, jjp1,rlatg,
+     .                 1,1,1,1,
+     .                 tau0, zjulian, dt_cum,
+     .                 thoriid, nid_ctesGCM)
+c
+         CALL histdef(nid_ctesGCM, "prt_level", 
+     .        "Niveau impression debuggage dynamique",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dayref", 
+     .        "Jour de l etat initial ( = 350  si 20 Decembre par ex.)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "anneeref", 
+     .        "Annee de l etat initial",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "anneelim", 
+     .        "Annee du fichier limitxxxx.nc  si  ok_limitvrai =y",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "raz_date", 
+     .   "Remise a zero (raz) date init.: 0 pas de raz;1=date gcm.def",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "nday", 
+     .   "Nombre de jours d integration",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "day_step", 
+     .   "nombre de pas par jour pour dt = 1 min",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iperiod", 
+     .   "periode pour le pas Matsuno (en pas de temps)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iapp_tracvl", 
+     .   "frequence du groupement des flux (en pas de temps)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iconser", 
+     .  "periode de sortie des variables de controle (en pas de temps)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iecri", 
+     .  "periode d ecriture du fichier histoire (en jour)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "periodav", 
+     .  "periode de stockage fichier histmoy (en jour)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "idissip", 
+     .  "periode de la dissipation (en pas) ... a completer",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "lstardis", 
+     .  "choix de l operateur de dissipation: 1= star,0=non-star ??",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "nitergdiv", 
+     .  "nombre d iterations de l operateur de dissipation gradiv",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "nitergrot", 
+     .  "nombre d iterations de l operateur de dissipation nxgradrot",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "niterh", 
+     .  "nombre d iterations de l operateur de dissipation divgrad",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tetagdiv", 
+     ."temps dissipation des + petites long. d ondes pour u,v (gradiv)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tetagrot", 
+     ."temps diss. des + petites long. d ondes pour u,v (nxgradrot)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tetatemp", 
+     ."temps diss. des + petites long. d ondes pour h (divgrad)",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "coefdis", 
+     ."coefficient pour gamdissip",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "purmats", 
+     ."Choix schema integration temporel: 1=Matsuno,0=Matsuno-leapfrog",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "ok_guide", 
+     ."Guidage: 1=true ,0=false",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "true_calendar", 
+     ."Choix du calendrier: 1=gregorien ,0=calen. a 360 j",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "guide_calend", 
+     ."Guidage calendrier gregorien: 1=oui ,0=non",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iflag_phys", 
+     ."Permet de faire tourner le modele sans physique: 1=avec ,0=sans",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "iphysiq", 
+     ."Periode de la physique en pas de temps de la dynamique",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "clon", 
+     ."longitude en degres du centre du zoom",
+     .                "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "clat", 
+     ."latitude en degres du centre du zoom",
+     .                "deg",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "grossismx", 
+     ."facteur de grossissement du zoom, selon la longitude",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "grossismy", 
+     ."facteur de grossissement du zoom, selon la latitude",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "fxyhypb", 
+     ."Fonction f(y) hyperbolique  si true=1, sinusoidale si false=0",
+     .                "-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dzoomx", 
+     ."extension en longitude de la zone du zoom (fraction zone totale)"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "dzoomy", 
+     ."extension en latitude de la zone du zoom (fraction zone totale)"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "taux", 
+     ."raideur du zoom en  X"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "tauy", 
+     ."raideur du zoom en  Y"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "ysinus", 
+     ."ysinus=1: Ftion f(y) avec y=Sin(latit.)/ ysinus=0: y = latit"
+     .                ,"-",iip1,jjp1,thoriid, 1,1,1, -99, 32, 
+     .                "once", dt_cum,dt_cum)
+c
+         CALL histdef(nid_ctesGCM, "ip_ebil_dyn", 
+     ."PRINTlevel for energy conservation diag.; 0/1= pas de print,
+     . 2= print","-",iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", dt_cum,dt_cum)
+c
+c=================================================================
+c
+         CALL histend(nid_ctesGCM)
+c
+c=================================================================
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/iniacademic.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/iniacademic.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/iniacademic.F	(revision 984)
@@ -0,0 +1,194 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE iniacademic(nq,vcov,ucov,teta,q,masse,ps,phis,time_0)
+
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 15/01/93
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "academic.h"
+#include "ener.h"
+#include "temps.h"
+#include "control.h"
+
+c   Arguments:
+c   ----------
+
+      integer nq
+      real time_0
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle
+      REAL q(ip1jmp1,llm,nq)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+
+
+
+
+
+c   Local:
+c   ------
+
+      REAL ddsin,tetarappelj,tetarappell,zsig
+      real tetajl(jjp1,llm)
+      INTEGER i,j,l,lsup,ij
+
+      real zz,ran1
+      integer idum
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
+
+c-----------------------------------------------------------------------
+
+c
+      time_0=0.
+
+      im         = iim
+      jm         = jjm
+      day_ini    = 0
+      omeg       = 4.*asin(1.)/86400.
+      rad    = 6371229.
+      g      = 9.8
+      daysec = 86400.
+      dtvr    = daysec/FLOAT(day_step)
+      zdtvr=dtvr
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      preff     = 101325.
+      pa        =  50 000.
+      etot0      = 0.
+      ptot0      = 0.
+      ztot0      = 0.
+      stot0      = 0.
+      ang0       = 0.
+      pa         = 0.
+
+      CALL inicons0
+      CALL inigeom
+      CALL inifilr
+
+      ps=0.
+      phis=0.
+c---------------------------------------------------------------------
+
+      taurappel=10.*daysec
+
+c---------------------------------------------------------------------
+c   Calcul de la temperature potentielle :
+c   --------------------------------------
+
+      DO l=1,llm
+       zsig=ap(l)/preff+bp(l)
+       if (zsig.gt.0.3) then
+         lsup=l
+         tetarappell=1./8.*(-log(zsig)-.5)
+         DO j=1,jjp1
+            ddsin=sin(rlatu(j))-sin(pi/20.)
+            tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell)
+         ENDDO
+        else
+c   Choix isotherme au-dessus de 300 mbar
+         do j=1,jjp1
+            tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
+         enddo
+        endif
+      ENDDO
+
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iip1
+               ij=(j-1)*iip1+i
+               tetarappel(ij,l)=tetajl(j,l)
+            enddo
+         enddo
+      enddo
+
+c     call dump2d(jjp1,llm,tetajl,'TEQ   ')
+
+      ps=1.e5
+      phis=0.
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+      CALL massdair(p,masse)
+
+c  intialisation du vent et de la temperature
+      teta(:,:)=tetarappel(:,:)
+      CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
+      call ugeostr(phi,ucov)
+      vcov=0.
+      q(:,:,1   )=1.e-10
+      q(:,:,2   )=1.e-15
+      q(:,:,3:nq)=0.
+
+
+c   perturbation al\351atoire sur la temp\351rature
+      idum  = -1
+      zz = ran1(idum)
+      idum  = 0
+      do l=1,llm
+         do ij=iip2,ip1jm
+            teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum))
+         enddo
+      enddo
+
+      do l=1,llm
+         do ij=1,ip1jmp1,iip1
+            teta(ij+iim,l)=teta(ij,l)
+         enddo
+      enddo
+
+
+
+c     PRINT *,' Appel test_period avec tetarappel '
+c     CALL  test_period ( ucov,vcov,tetarappel,q,p,phis )
+c     PRINT *,' Appel test_period avec teta '
+c     CALL  test_period ( ucov,vcov,teta,q,p,phis )
+
+c   initialisation d'un traceur sur une colonne
+      j=jjp1*3/4
+      i=iip1/2
+      ij=(j-1)*iip1+i
+      q(ij,:,3)=1.
+
+      return
+      END
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/iniadvtrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/iniadvtrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/iniadvtrac.F	(revision 984)
@@ -0,0 +1,245 @@
+!
+! $Header$
+!
+c
+c
+      subroutine iniadvtrac(nq)
+      USE ioipsl
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c   Modif special traceur F.Forget 05/94
+c   Modif M-A Filiberti 02/02 lecture de traceur.def
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c   ... modification de l'integration de q ( 26/04/94 ) ....
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+C
+#include "dimensions.h"
+#include "advtrac.h"
+#include "control.h"
+c   local
+      character*3 descrq(30)
+      character*1 txts(3)
+      character*2 txtp(9)
+      character*13 str1,str2,str3
+
+      integer nq,iq,iiq,iiiq,ierr,ii
+      integer lnblnk
+      external lnblnk
+
+      data txts/'x','y','z'/
+      data txtp/'x','y','z','xx','xy','xz','yy','yz','zz'/
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+      descrq(14)='VLH'
+      descrq(10)='VL1'
+      descrq(11)='VLP'
+      descrq(12)='FH1'
+      descrq(13)='FH2'
+      descrq(16)='PPM'
+      descrq(17)='PPS'
+      descrq(18)='PPP'
+      descrq(20)='SLP'
+      descrq(30)='PRA'
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         CALL init_transport( 
+     $        hadv_flg,
+     $        vadv_flg,
+     $        conv_flg,
+     $        pbl_flg,
+     $        tracnam)
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c        Choix  des schemas d'advection pour l'eau et les traceurs
+c
+c     iadv = 1    schema  transport type "humidite specifique LMD"
+c     iadv = 2    schema   amont
+c     iadv = 14    schema  Van-leer + humidite specifique 
+c                            Modif F.Codron
+c     iadv = 10   schema  Van-leer (retenu pour l'eau vapeur et liquide)
+c     iadv = 11   schema  Van-Leer pour hadv et version PPM (Monotone) pour vadv
+c     iadv = 12   schema  Frederic Hourdin I
+c     iadv = 13   schema  Frederic Hourdin II
+c     iadv = 16   schema  PPM Monotone(Collela & Woodward 1984)
+c     iadv = 17   schema  PPM Semi Monotone (overshoots autorisés)
+c     iadv = 18   schema  PPM Positif Defini (overshoots undershoots autorisés)
+c     iadv = 20   schema  Slopes
+c     iadv = 30   schema  Prather
+c
+c        Dans le tableau q(ij,l,iq) : iq = 1  pour l'eau vapeur
+c                                     iq = 2  pour l'eau liquide
+c        Et eventuellement            iq = 3,nqmx pour les autres traceurs
+c
+c        iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+C------------------------------------------------------------------------
+c     Choix du schema d'advection
+c------------------------------------------------------------------
+c choix par defaut = van leer pour tous les traceurs
+      do iq=1,nqmx
+       iadv(iq)=10
+       str1(1:1)='q'
+       if (nqmx.le.99) then
+       WRITE(str1(2:3),'(i2.2)') iq
+       else
+       WRITE(str1(2:4),'(i3.3)') iq
+       endif
+       tnom(iq)=str1
+       tname(iq)=tnom(iq) 
+       str2=tnom(iq) 
+       ttext(iq)=str2(1:lnblnk(str2))//descrq(iadv(iq))
+      end do
+      nq=nqmx
+c------------------------------------------------------------------
+c     Choix du schema pour l'advection
+c    dans fichier traceur.def
+c------------------------------------------------------------------
+      IF (config_inca == 'none') THEN
+         print*,'ouverture de traceur.def'
+         open(90,file='traceur.def',form='formatted',status='old',
+     s        iostat=ierr)
+         if(ierr.eq.0) then
+            print*,'ouverture de traceur.def ok'
+            read(90,*) nq
+            print*,'nombre de traceurs ',nq
+            if (nq.gt.nqmx) then
+               print*,'nombre de traceurs trop important'
+               print*,'verifier traceur.def'
+               stop
+            endif
+C     
+            do iq=1,nq
+               read(90,999) hadv(iq),vadv(iq),tnom(iq)
+            end do
+            close(90)  
+            PRINT*,'lecture de traceur.def :'   
+            do iq=1,nq
+               write(*,*) hadv(iq),vadv(iq),tnom(iq)
+            end do       
+         else
+            print*,'pb ouverture traceur.def'
+            print*,'ATTENTION on prend des valeurs par defaut'
+            nq = 4
+            hadv(1) = 14
+            vadv(1) = 14
+            tnom(1) = 'H2Ov'
+            hadv(2) = 10
+            vadv(2) = 10
+            tnom(2) = 'H2Ol'
+            hadv(3) = 10
+            vadv(3) = 10
+            tnom(3) = 'RN'
+            hadv(4) = 10
+            vadv(4) = 10
+            tnom(4) = 'PB'
+         ENDIF
+         PRINT*,'Valeur de traceur.def :'
+         do iq=1,nq
+            write(*,*) hadv(iq),vadv(iq),tnom(iq)
+         end do       
+      ELSE  ! config_inca='aero' ou 'chem'
+C le module de chimie fournit les noms des traceurs
+C et les schemas d'advection associes.
+         tnom(1)='H2Ov'
+         tnom(2)='H2Ol'
+         nq=nbtrac+2
+         if (nq.gt.nqmx) then
+            print*,'nombre de traceurs incompatible INCA/LMDZT'
+            stop
+         endif
+         do iq =3,nq
+            tnom(iq)=tracnam(iq-2)
+         end do
+         do iq =1,nq
+            hadv(iq)= hadv_flg(iq) 
+            vadv(iq)= vadv_flg(iq) 
+         end do
+      END IF ! config_inca
+
+c a partir du nom court du traceur et du schema d'advection au detemine le nom long.
+        iiq=0
+        ii=0
+        do iq=1,nq 
+         iiq=iiq+1
+         if (hadv(iq).ne.vadv(iq)) then
+           if (hadv(iq).eq.10.and.vadv(iq).eq.16) then
+             iadv(iiq)=11
+           else
+             print*,'le choix des schemas d''advection H et V'
+             print*, 'est non disponible actuellement'
+             stop 
+           endif
+         else
+          iadv(iiq)=hadv(iq)
+         endif
+c verification nombre de traceurs
+          if (iadv(iiq).lt.20) then
+             ii=ii+1
+          elseif (iadv(iiq).eq.20) then
+             ii=ii+4
+          elseif (iadv(iiq).eq.30) then
+             ii=ii+10
+          endif
+ 
+         str1=tnom(iq)
+         tname(iiq)=tnom(iq)
+         IF (iadv(iiq).eq.0) THEN
+           ttext(iiq)=str1(1:lnblnk(str1))
+         ELSE
+           ttext(iiq)=str1(1:lnblnk(str1))//descrq(iadv(iiq))
+         endif
+         str2=ttext(iiq)
+c   schemas tenant compte des moments d'ordre superieur.
+          if (iadv(iiq).eq.20) then
+             do iiiq=1,3
+               iiq=iiq+1
+               iadv(iiq)=-20
+               ttext(iiq)=str2(1:lnblnk(str2))//txts(iiiq)
+               tname(iiq)=str1(1:lnblnk(str1))//txts(iiiq)
+              enddo
+            elseif (iadv(iiq).eq.30) then
+              do iiiq=1,9
+               iiq=iiq+1
+               iadv(iiq)=-30
+               ttext(iiq)=str2(1:lnblnk(str2))//txtp(iiiq)
+               tname(iiq)=str1(1:lnblnk(str1))//txtp(iiiq)
+              enddo
+           endif
+        end do
+       if(ii.ne.nqmx) then
+       print*,'WARNING'
+       print*,'le nombre de traceurs et de moments eventuels'
+       print*,'est inferieur a nqmx '
+       endif
+       if (iiq.gt.nqmx) then
+       print*,'le choix des schemas est incompatible avec '
+       print*,'la dimension nqmx (nombre de traceurs)'
+       print*,'verifier traceur.def ou la namelist INCA'
+       print*,'ou recompiler avec plus de traceurs'
+       stop
+       endif
+      iiq=0
+      do iq=1,nqmx
+         if(iadv(iq).ge.0) then
+             iiq=iiq+1
+             niadv(iiq)=iq
+         endif
+      end do
+      return
+999   format (i2,1x,i2,1x,a8)
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inicons0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inicons0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inicons0.F	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+      SUBROUTINE inicons0
+      IMPLICIT NONE
+c
+c  P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "control.h"
+#include "comvert.h"
+#include "comdissnew.h"
+
+
+c
+c
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+      r       = cpp * kappa
+
+      PRINT*,' Cp R  kappa ',  cpp, r , kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/iniconst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/iniconst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/iniconst.F	(revision 984)
@@ -0,0 +1,57 @@
+!
+! $Header$
+!
+      SUBROUTINE iniconst
+
+      IMPLICIT NONE
+c
+c      P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "control.h"
+#include "comvert.h"
+
+
+c
+c
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+c
+
+      r       = cpp * kappa
+
+      PRINT*,' R  CP  Kappa ',  r , cpp,  kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inidissip.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inidissip.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inidissip.F	(revision 984)
@@ -0,0 +1,216 @@
+!
+! $Header$
+!
+      SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  ,
+     *                       tetagdiv,tetagrot,tetatemp             )
+c=======================================================================
+c   initialisation de la dissipation horizontale
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "control.h"
+
+      LOGICAL lstardis
+      INTEGER nitergdiv,nitergrot,niterh
+      REAL    tetagdiv,tetagrot,tetatemp
+      REAL fact,zvert(llm),zz
+      REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm)
+      REAL ullm,vllm,umin,vmin,zhmin,zhmax
+      REAL zllm,z1llm
+
+      INTEGER l,ij,idum,ii
+      REAL tetamin
+
+      REAL ran1
+
+
+c-----------------------------------------------------------------------
+c
+c   calcul des valeurs propres des operateurs par methode iterrative:
+c   -----------------------------------------------------------------
+
+      crot     = -1.
+      cdivu    = -1.
+      cdivh    = -1.
+
+c   calcul de la valeur propre de divgrad:
+c   --------------------------------------
+      idum = 0
+      DO l = 1, llm
+       DO ij = 1, ip1jmp1
+        deltap(ij,l) = 1.
+       ENDDO
+      ENDDO
+
+      idum  = -1
+      zh(1) = RAN1(idum)-.5
+      idum  = 0
+      DO ij = 2, ip1jmp1
+        zh(ij) = RAN1(idum) -.5
+      ENDDO
+
+      CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
+
+      CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+      IF ( zhmin .GE. zhmax  )     THEN
+         PRINT*,'  Inidissip  zh min max  ',zhmin,zhmax
+         STOP'probleme generateur alleatoire dans inidissip'
+      ENDIF
+
+      zllm = ABS( zhmax )
+      DO l = 1,50
+         IF(lstardis) THEN
+            CALL divgrad2(1,zh,deltap,niterh,zh)
+         ELSE
+            CALL divgrad (1,zh,niterh,zh)
+         ENDIF
+
+        CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+         zllm  = ABS( zhmax )
+         z1llm = 1./zllm
+         DO ij = 1,ip1jmp1
+            zh(ij) = zh(ij)* z1llm
+         ENDDO
+      ENDDO
+
+      IF(lstardis) THEN
+         cdivh = 1./ zllm
+      ELSE
+         cdivh = zllm ** ( -1./niterh )
+      ENDIF
+
+c   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
+c   -----------------------------------------------------------------
+      print*,'calcul des valeurs propres'
+
+      DO  20  ii = 1, 2
+c
+         DO ij = 1, ip1jmp1
+           zu(ij)  = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
+         DO ij = 1, ip1jm
+            zv(ij) = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
+
+         CALL minmax(iip1*jjp1,zu,umin,ullm )
+         CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+         ullm = ABS ( ullm )
+         vllm = ABS ( vllm )
+
+         DO  5  l = 1, 50
+            IF(ii.EQ.1) THEN
+ccccc             CALL covcont( 1,zu,zv,zu,zv )
+               IF(lstardis) THEN
+                  CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv )
+               ELSE
+                  CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv )
+               ENDIF
+            ELSE
+               IF(lstardis) THEN
+                  CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv )
+               ELSE
+                  CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv )
+               ENDIF
+            ENDIF
+
+            CALL minmax(iip1*jjp1,zu,umin,ullm )
+            CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+            ullm = ABS  ( ullm )
+            vllm = ABS  ( vllm )
+
+            zllm  = MAX( ullm,vllm )
+            z1llm = 1./ zllm
+            DO ij = 1, ip1jmp1
+              zu(ij) = zu(ij)* z1llm
+            ENDDO
+            DO ij = 1, ip1jm
+               zv(ij) = zv(ij)* z1llm
+            ENDDO
+ 5       CONTINUE
+
+         IF ( ii.EQ.1 ) THEN
+            IF(lstardis) THEN
+               cdivu  = 1./zllm
+            ELSE
+               cdivu  = zllm **( -1./nitergdiv )
+            ENDIF
+         ELSE
+            IF(lstardis) THEN
+               crot   = 1./ zllm
+            ELSE
+               crot   = zllm **( -1./nitergrot )
+            ENDIF
+         ENDIF
+
+ 20   CONTINUE
+
+c   petit test pour les operateurs non star:
+c   ----------------------------------------
+
+c     IF(.NOT.lstardis) THEN
+         fact    = rad*24./float(jjm)
+         fact    = fact*fact
+         PRINT*,'coef u ', fact/cdivu, 1./cdivu
+         PRINT*,'coef r ', fact/crot , 1./crot
+         PRINT*,'coef h ', fact/cdivh, 1./cdivh
+c     ENDIF
+
+c-----------------------------------------------------------------------
+c   variation verticale du coefficient de dissipation:
+c   --------------------------------------------------
+
+      DO l=1,llm
+         zvert(l)=1.
+      ENDDO
+
+      fact=2.
+c
+      DO l = 1, llm
+         zz      = 1. - preff/presnivs(l)
+         zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
+      ENDDO
+
+
+      PRINT*,'Constantes de temps de la diffusion horizontale'
+
+      tetamin =  1.e+6
+
+      DO l=1,llm
+        tetaudiv(l)   = zvert(l)/tetagdiv
+        tetaurot(l)   = zvert(l)/tetagrot
+        tetah(l)      = zvert(l)/tetatemp
+
+        IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
+        IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
+        IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
+      ENDDO
+
+      PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod
+      idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+      PRINT *,' INIDI tetamin idissip ',tetamin,idissip
+      idissip = MAX(iperiod,idissip)
+      dtdiss  = idissip * dtvr
+      PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss
+
+      DO l = 1,llm
+         PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l),
+     *                   dtdiss*tetah(l)
+      ENDDO
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inigeom.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inigeom.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inigeom.F	(revision 984)
@@ -0,0 +1,699 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE inigeom
+c
+c     Auteur :  P. Le Van
+c
+c   ............      Version  du 01/04/2001     ........................
+c
+c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+c     endroits que les aires aireij1,..aireij4 .
+
+c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "serre.h"
+#include "logic.h"
+#include "comdissnew.h"
+
+c-----------------------------------------------------------------------
+c   ....  Variables  locales   ....
+c
+      INTEGER  i,j,itmax,itmay,iter
+      REAL cvu(iip1,jjp1),cuv(iip1,jjm)
+      REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
+      REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm
+      REAL coslatm,coslatp,radclatm,radclatp
+      REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1),
+     *     cuij4(iip1,jjp1)
+      REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1),
+     *     cvij4(iip1,jjp1)
+      REAL rlonvv(iip1),rlatuu(jjp1)
+      REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) ,
+     *     yprimv(jjm),yprimu(jjp1)
+      REAL gamdi_gdiv, gamdi_grot, gamdi_h
+ 
+      REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),
+     ,  xprimp025(iip1)
+      SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
+      SAVE rlonm025,xprimm025,rlonp025,xprimp025
+
+      REAL      SSUM
+c
+c
+c   ------------------------------------------------------------------
+c   -                                                                -
+c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+c   -                                                                -
+c   ------------------------------------------------------------------
+c
+c      les coef. ( cu, cv ) permettent de passer des vitesses naturelles
+c      aux vitesses covariantes et contravariantes , ou vice-versa ...
+c
+c
+c     on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
+c             v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
+c
+c       on en tire :  u(covariant) = cu * cu * u(contravariant)
+c                     v(covariant) = cv * cv * v(contravariant)
+c
+c
+c     on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
+c                                                          =     =
+c                                           et   - jm/2    <  Y  < jm/2
+c                                                          =     =
+c
+c      ...................................................
+c      ...................................................
+c      .  x  est la longitude du point  en radians       .
+c      .  y  est la  latitude du point  en radians       .
+c      .                                                 .
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+c      .        aire(i,j) =  cu(i,j) * cv(j)             .
+c      .                                                 .
+c      . y, dx/dX, dy/dY calcules aux points concernes   .
+c      .                                                 .
+c      ...................................................
+c      ...................................................
+c
+c
+c
+c                                                           ,
+c    cv , bien que dependant de j uniquement,sera ici indice aussi en i
+c          pour un adressage plus facile en  ij  .
+c
+c
+c
+c  **************  aux points  u  et  v ,           *****************
+c      xprimu et xprimv sont respectivement les valeurs de  dx/dX
+c      yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
+c      rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
+c      cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
+c
+c  **************  aux points u, v, scalaires, et z  ****************
+c      cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
+c
+c
+c
+c         Exemple de distribution de variables sur la grille dans le
+c             domaine de travail ( X,Y ) .
+c     ................................................................
+c                  DX=DY= 1
+c
+c   
+c        +     represente  un  point scalaire ( p.exp  la pression )
+c        >     represente  la composante zonale du  vent
+c        V     represente  la composante meridienne du vent
+c        o     represente  la  vorticite
+c
+c       ----  , car aux poles , les comp.zonales covariantes sont nulles
+c
+c
+c
+c         i ->
+c
+c         1      2      3      4      5      6      7      8
+c  j
+c  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c
+c      Ci-dessus,  on voit que le nombre de pts.en longitude est egal
+c                 a   IM = 8
+c      De meme ,   le nombre d'intervalles entre les 2 poles est egal
+c                 a   JM = 4
+c
+c      Les points scalaires ( + ) correspondent donc a des valeurs
+c       entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
+c
+c      Les vents    U       ( > ) correspondent a des valeurs  semi-
+c       entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
+c
+c      Les vents    V       ( V ) correspondent a des valeurs entieres
+c       de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
+c
+c
+c
+      WRITE(6,3) 
+ 3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
+     * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
+     *  5x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux 
+     * '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
+c
+c
+      IF( nitergdiv.NE.2 ) THEN
+        gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. )
+      ELSE
+        gamdi_gdiv = 0.
+      ENDIF
+      IF( nitergrot.NE.2 ) THEN
+        gamdi_grot = coefdis/ ( float(nitergrot) -2. )
+      ELSE
+        gamdi_grot = 0.
+      ENDIF
+      IF( niterh.NE.2 ) THEN
+        gamdi_h = coefdis/ ( float(niterh) -2. )
+      ELSE
+        gamdi_h = 0.
+      ENDIF
+
+      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+     *  nitergdiv,nitergrot,niterh
+c
+      pi    = 2.* ASIN(1.)
+c
+      WRITE(6,990) 
+
+c     ----------------------------------------------------------------
+c
+      IF( .NOT.fxyhypb )   THEN
+c
+c
+       IF( ysinus )  THEN
+c
+        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+c
+c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
+
+        CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ELSE
+c
+        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+
+c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
+c
+ 
+        pxo   = clon *pi /180.
+        pyo   = 2.* clat* pi /180.
+c
+c  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
+c
+        itmax = 10
+        eps   = .1e-7
+c
+        xo1 = 0.
+        DO 10 iter = 1, itmax
+        x1  = xo1
+        f   = x1+ alphax *SIN(x1-pxo)
+        df  = 1.+ alphax *COS(x1-pxo)
+        x1  = x1 - f/df
+        xdm = ABS( x1- xo1 )
+        IF( xdm.LE.eps )GO TO 11
+        xo1 = x1
+ 10     CONTINUE
+ 11     CONTINUE
+c
+        transx = xo1
+
+        itmay = 10
+        eps   = .1e-7
+C
+        yo1  = 0.
+        DO 15 iter = 1,itmay
+        y1   = yo1
+        f    = y1 + alphay* SIN(y1-pyo)
+        df   = 1. + alphay* COS(y1-pyo)
+        y1   = y1 -f/df
+        ydm  = ABS(y1-yo1)
+        IF(ydm.LE.eps) GO TO 17
+        yo1  = y1
+ 15     CONTINUE
+c
+ 17     CONTINUE
+        transy = yo1
+
+        CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,              rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ENDIF
+c
+      ELSE
+c
+c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+c   .....................................................................
+
+      WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+ 
+       CALL fxyhyper( clat, grossismy, dzoomy, tauy    , 
+     ,                clon, grossismx, dzoomx, taux    ,
+     , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2  ,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 )
+
+  
+      ENDIF
+c
+c  -------------------------------------------------------------------
+
+c
+      rlatu(1)    =     ASIN(1.)
+      rlatu(jjp1) =  - rlatu(1)
+c
+c
+c   ....  calcul  aux  poles  ....
+c
+      yprimu(1)      = 0.
+      yprimu(jjp1)   = 0.
+c
+c
+      un4rad2 = 0.25 * rad * rad
+c
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c   -                                                                  -
+c   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
+c   -      et de   fext ,  force de coriolis  extensive  .             -
+c   -                                                                  -
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c
+c
+c
+c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+c   affectees 4 aires entourant P , calculees respectivement aux points
+c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+c
+c           ,
+c   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
+c   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
+c   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
+c   point (i,j) .
+c   On definit en outre les coefficients  alpha comme etant egaux a
+c    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
+c
+c   De meme, toute aire centree en 1 point U est egale a la somme des
+c   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
+c    Idem pour  airev, airez .
+c
+c       On a ,pour chaque maille :    dX = dY = 1
+c
+c
+c                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+c
+c
+c
+c
+c
+c   ....................................................................
+c
+c    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
+c   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
+c   taires cuij et les 4 elongat. cvij qui sont calculees aux memes 
+c     endroits  que les aireij   .    
+c
+c   ....................................................................
+c
+c     .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
+c
+c
+      DO 35 j = 1, jjp1
+c
+      IF ( j. eq. 1 )  THEN
+c
+      yprm           = yprimu1(j)
+      rlatm          = rlatu1(j)
+c
+      coslatm        = COS( rlatm )
+      radclatm       = 0.5* rad * coslatm
+c
+      DO 30 i = 1, iim
+      xprp           = xprimp025( i )
+      xprm           = xprimm025( i )
+      aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
+      aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
+      cuij2  ( i,1 ) = radclatm * xprp
+      cuij3  ( i,1 ) = radclatm * xprm
+      cvij2  ( i,1 ) = 0.5* rad * yprm
+      cvij3  ( i,1 ) = cvij2(i,1)
+  30  CONTINUE
+c
+      DO  i = 1, iim
+      aireij1( i,1 ) = 0.
+      aireij4( i,1 ) = 0.
+      cuij1  ( i,1 ) = 0.
+      cuij4  ( i,1 ) = 0.
+      cvij1  ( i,1 ) = 0.
+      cvij4  ( i,1 ) = 0.
+      ENDDO
+c
+      END IF
+c
+      IF ( j. eq. jjp1 )  THEN
+       yprp               = yprimu2(j-1)
+       rlatp              = rlatu2 (j-1)
+ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
+ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
+c
+      coslatp             = COS( rlatp )
+      radclatp            = 0.5* rad * coslatp
+c
+      DO 31 i = 1,iim
+        xprp              = xprimp025( i )
+        xprm              = xprimm025( i )
+        aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
+        aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
+        cuij1(i,jjp1)     = radclatp * xprp
+        cuij4(i,jjp1)     = radclatp * xprm
+        cvij1(i,jjp1)     = 0.5 * rad* yprp
+        cvij4(i,jjp1)     = cvij1(i,jjp1)
+ 31   CONTINUE
+c
+       DO   i    = 1, iim
+        aireij2( i,jjp1 ) = 0.
+        aireij3( i,jjp1 ) = 0.
+        cvij2  ( i,jjp1 ) = 0.
+        cvij3  ( i,jjp1 ) = 0.
+        cuij2  ( i,jjp1 ) = 0.
+        cuij3  ( i,jjp1 ) = 0.
+       ENDDO
+c
+      END IF
+c
+
+      IF ( j .gt. 1 .AND. j .lt. jjp1 )  THEN
+c
+        rlatp    = rlatu2 ( j-1 )
+        yprp     = yprimu2( j-1 )
+        rlatm    = rlatu1 (  j  )
+        yprm     = yprimu1(  j  )
+cc         rlatp    = fy    ( FLOAT(j) - 0.25 )
+cc         yprp     = fyprim( FLOAT(j) - 0.25 )
+cc         rlatm    = fy    ( FLOAT(j) + 0.25 )
+cc         yprm     = fyprim( FLOAT(j) + 0.25 )
+
+         coslatm  = COS( rlatm )
+         coslatp  = COS( rlatp )
+         radclatp = 0.5* rad * coslatp
+         radclatm = 0.5* rad * coslatm
+c
+         DO 32 i = 1,iim
+         xprp            = xprimp025( i )
+         xprm            = xprimm025( i )
+      
+         ai14            = un4rad2 * coslatp * yprp
+         ai23            = un4rad2 * coslatm * yprm
+         aireij1 ( i,j ) = ai14 * xprp
+         aireij2 ( i,j ) = ai23 * xprp
+         aireij3 ( i,j ) = ai23 * xprm
+         aireij4 ( i,j ) = ai14 * xprm
+         cuij1   ( i,j ) = radclatp * xprp
+         cuij2   ( i,j ) = radclatm * xprp
+         cuij3   ( i,j ) = radclatm * xprm
+         cuij4   ( i,j ) = radclatp * xprm
+         cvij1   ( i,j ) = 0.5* rad * yprp
+         cvij2   ( i,j ) = 0.5* rad * yprm
+         cvij3   ( i,j ) = cvij2(i,j)
+         cvij4   ( i,j ) = cvij1(i,j)
+  32     CONTINUE
+c
+      END IF
+c
+c    ........       periodicite   ............
+c
+         cvij1   (iip1,j) = cvij1   (1,j)
+         cvij2   (iip1,j) = cvij2   (1,j)
+         cvij3   (iip1,j) = cvij3   (1,j)
+         cvij4   (iip1,j) = cvij4   (1,j)
+         cuij1   (iip1,j) = cuij1   (1,j)
+         cuij2   (iip1,j) = cuij2   (1,j)
+         cuij3   (iip1,j) = cuij3   (1,j)
+         cuij4   (iip1,j) = cuij4   (1,j)
+         aireij1 (iip1,j) = aireij1 (1,j )
+         aireij2 (iip1,j) = aireij2 (1,j )
+         aireij3 (iip1,j) = aireij3 (1,j )
+         aireij4 (iip1,j) = aireij4 (1,j )
+        
+  35  CONTINUE
+c
+c    ..............................................................
+c
+      DO 37 j = 1, jjp1
+      DO 36 i = 1, iim
+      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
+     *                          aireij4(i,j)
+      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+  36  CONTINUE
+c
+c
+      aire    (iip1,j) = aire    (1,j)
+      alpha1  (iip1,j) = alpha1  (1,j)
+      alpha2  (iip1,j) = alpha2  (1,j)
+      alpha3  (iip1,j) = alpha3  (1,j)
+      alpha4  (iip1,j) = alpha4  (1,j)
+      alpha1p2(iip1,j) = alpha1p2(1,j)
+      alpha1p4(iip1,j) = alpha1p4(1,j)
+      alpha2p3(iip1,j) = alpha2p3(1,j)
+      alpha3p4(iip1,j) = alpha3p4(1,j)
+  37  CONTINUE
+c
+
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                                aireij3(i+1,j)
+      unsaire    ( i,j)= 1./ aire(i,j)
+      unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
+      unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
+      airesurg   ( i,j)= aire(i,j)/ g
+  41  CONTINUE
+      aireu     (iip1,j)  = aireu  (1,j)
+      unsaire   (iip1,j)  = unsaire(1,j)
+      unsair_gam1(iip1,j) = unsair_gam1(1,j)
+      unsair_gam2(iip1,j) = unsair_gam2(1,j)
+      airesurg   (iip1,j) = airesurg(1,j)
+  42  CONTINUE
+c
+c
+      DO 48 j = 1,jjm
+c
+        DO i=1,iim
+         airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+         DO i=1,iim
+          airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) +
+     *                           aireij4(i+1,j+1)
+          unsairez(i,j) = 1./ airez
+          unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
+          fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
+         ENDDO
+        airev     (iip1,j)  = airev(1,j)
+        unsairez  (iip1,j)  = unsairez(1,j)
+        fext      (iip1,j)  = fext(1,j)
+        unsairz_gam(iip1,j) = unsairz_gam(1,j)
+c
+  48  CONTINUE
+c
+c
+c    .....      Calcul  des elongations cu,cv, cvu     .........
+c
+      DO    j   = 1, jjm
+       DO   i  = 1, iim
+       cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
+       cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
+       cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
+       unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
+       ENDDO
+       DO   i  = 1, iim
+       cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
+       cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
+       cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
+       cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
+       cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
+       ENDDO
+       cv       (iip1,j)  = cv       (1,j)
+       cvu      (iip1,j)  = cvu      (1,j)
+       unscv2   (iip1,j)  = unscv2   (1,j)
+       cuv      (iip1,j)  = cuv      (1,j)
+       cuvsurcv (iip1,j)  = cuvsurcv (1,j)
+       cvsurcuv (iip1,j)  = cvsurcuv (1,j)
+       cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
+       cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
+       cvscuvgam(iip1,j)  = cvscuvgam(1,j)
+      ENDDO
+
+      DO  j     = 2, jjm
+        DO   i  = 1, iim
+        cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
+        unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
+        cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
+        cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
+        cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) 
+        cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    ) 
+        cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
+        ENDDO
+        cu       (iip1,j)  = cu(1,j)
+        unscu2   (iip1,j)  = unscu2(1,j)
+        cvusurcu (iip1,j)  = cvusurcu(1,j)
+        cusurcvu (iip1,j)  = cusurcvu(1,j)
+        cvuscugam1(iip1,j) = cvuscugam1(1,j)
+        cvuscugam2(iip1,j) = cvuscugam2(1,j)
+        cuscvugam (iip1,j) = cuscvugam(1,j)
+      ENDDO
+
+c
+c   ....  calcul aux  poles  ....
+c
+      DO    i      =  1, iip1
+        cu    ( i, 1 )  =   0.
+        unscu2( i, 1 )  =   0.
+        cvu   ( i, 1 )  =   0.
+c
+        cu    (i, jjp1) =   0.
+        unscu2(i, jjp1) =   0.
+        cvu   (i, jjp1) =   0.
+      ENDDO
+c
+c    ..............................................................
+c
+      DO j = 1, jjm
+        DO i= 1, iim
+         airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
+         aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
+        ENDDO
+         airvscu2  (iip1,j)  = airvscu2(1,j)
+         aivscu2gam(iip1,j)  = aivscu2gam(1,j)
+      ENDDO
+
+      DO j=2,jjm
+        DO i=1,iim
+         airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
+         aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot ) 
+        ENDDO
+         airuscv2  (iip1,j)  = airuscv2  (1,j)
+         aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
+      ENDDO
+
+c
+c   calcul des aires aux  poles :
+c   -----------------------------
+c
+      apoln       = SSUM(iim,aire(1,1),1)
+      apols       = SSUM(iim,aire(1,jjp1),1)
+      unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
+      unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
+      unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
+      unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
+c
+c-----------------------------------------------------------------------
+c     gtitre='Coriolis version ancienne'
+c     gfichier='fext1'
+c     CALL writestd(fext,iip1*jjm)
+c
+c   changement F. Hourdin calcul conservatif pour fext
+c   constang contient le produit a * cos ( latitude ) * omega
+c
+      DO i=1,iim
+         constang(i,1) = 0.
+      ENDDO
+      DO j=1,jjm-1
+        DO i=1,iim
+         constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
+        ENDDO
+      ENDDO
+      DO i=1,iim
+         constang(i,jjp1) = 0.
+      ENDDO
+c
+c   periodicite en longitude
+c
+      DO j=1,jjm
+        fext(iip1,j)     = fext(1,j)
+      ENDDO
+      DO j=1,jjp1
+        constang(iip1,j) = constang(1,j)
+      ENDDO
+
+c fin du changement
+
+c
+c-----------------------------------------------------------------------
+c
+       WRITE(6,*) '   ***  Coordonnees de la grille  *** '
+       WRITE(6,995)
+c
+       WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,iip1
+         rlonvv(i) = rlonv(i)*180./pi
+        ENDDO
+       WRITE(6,400) rlonvv
+c
+       WRITE(6,995)
+       WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjm
+         rlatuu(i)=rlatv(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjm)
+c
+        DO i=1,iip1
+          rlonvv(i)=rlonu(i)*180./pi
+        ENDDO
+       WRITE(6,995)
+       WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
+       WRITE(6,995)
+       WRITE(6,400) rlonvv
+       WRITE(6,995)
+
+       WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjp1
+         rlatuu(i)=rlatu(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjp1)
+       WRITE(6,995)
+c
+444    format(f10.3,f6.0)
+400    FORMAT(1x,8f8.2)
+990    FORMAT(//)
+995    FORMAT(/)
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inigrads.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inigrads.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inigrads.F	(revision 984)
@@ -0,0 +1,92 @@
+!
+! $Header$
+!
+      subroutine inigrads(if,im
+     s  ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz
+     s  ,dt,file,titlel)
+
+
+      implicit none
+
+      integer if,im,jm,lm,i,j,l,lnblnk
+      real x(im),y(jm),z(lm),fx,fy,fz,dt
+      real xmin,xmax,ymin,ymax
+
+      character file*10,titlel*40
+
+#include "gradsdef.h"
+
+c     data unit/66,32,34,36,38,40,42,44,46,48/
+      integer nf
+      save nf
+      data nf/0/
+
+      unit(1)=66
+      unit(2)=32
+      unit(3)=34
+      unit(4)=36
+      unit(5)=38
+      unit(6)=40
+      unit(7)=42
+      unit(8)=44
+      unit(9)=46
+
+      if (if.le.nf) stop'verifier les appels a inigrads'
+
+      print*,'Entree dans inigrads'
+
+      nf=if
+      title(if)=titlel
+      ivar(if)=0
+
+      fichier(if)=file(1:lnblnk(file))
+
+      firsttime(if)=.true.
+      dtime(if)=dt
+
+      iid(if)=1
+      ifd(if)=im
+      imd(if)=im
+      do i=1,im
+         xd(i,if)=x(i)*fx
+         if(xd(i,if).lt.xmin) iid(if)=i+1
+         if(xd(i,if).le.xmax) ifd(if)=i
+      enddo
+      print*,'On stoke du point ',iid(if),'  a ',ifd(if),' en x'
+
+      jid(if)=1
+      jfd(if)=jm
+      jmd(if)=jm
+      do j=1,jm
+         yd(j,if)=y(j)*fy
+         if(yd(j,if).gt.ymax) jid(if)=j+1
+         if(yd(j,if).ge.ymin) jfd(if)=j
+      enddo
+      print*,'On stoke du point ',jid(if),'  a ',jfd(if),' en y'
+
+      print*,'Open de dat'
+      print*,'file=',file
+      print*,'fichier(if)=',fichier(if)
+
+      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
+      print*,file(1:lnblnk(file))//'.dat'
+
+      OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat'
+     s   ,FORM='unformatted',
+     s   ACCESS='direct'
+     s  ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1))
+
+      print*,'Open de dat ok'
+
+      lmd(if)=lm
+      do l=1,lm
+         zd(l,if)=z(l)*fz
+      enddo
+
+      irec(if)=0
+
+      print*,if,imd(if),jmd(if),lmd(if)
+      print*,'if,imd(if),jmd(if),lmd(if)'
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/iniinterp_horiz.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/iniinterp_horiz.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/iniinterp_horiz.F	(revision 984)
@@ -0,0 +1,179 @@
+C 
+C $Header$
+C
+      subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &       ktotal,iik,jjk,jk,ik,intersec,airen)
+   
+      implicit none
+
+
+
+c ---------------------------------------------------------
+c Prepare l' interpolation des variables d'une grille LMDZ
+c  dans une autre grille LMDZ en conservant la quantite
+c  totale pour les variables intensives (/m2) : ex : Pression au sol
+c
+c   (Pour chaque case autour d'un point scalaire de la nouvelle
+c    grille, on calcule la surface (en m2)en intersection avec chaque
+c    case de l'ancienne grille , pour la future interpolation)
+c
+c on calcule aussi l' aire dans la nouvelle grille 
+c
+c
+c   Auteur:  F.Forget 01/1995
+c   -------
+c
+c ---------------------------------------------------------
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+c INPUT
+       integer imo, jmo ! dimensions ancienne grille
+       integer imn,jmn  ! dimensions nouvelle grille
+       integer kllm ! taille du tableau des intersections
+       real rlonuo(imo+1)     !  Latitude et
+       real rlatvo(jmo)       !  longitude des
+       real rlonun(imn+1)     !  bord des
+       real rlatvn(jmn)     !  cases "scalaires" (input)
+
+c OUTPUT
+       integer ktotal ! nombre totale d'intersections reperees
+       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
+       real intersec(kllm)  ! surface des intersections (m2)
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+
+
+       
+ 
+c Autres variables
+c """"""""""""""""
+       integer i,j,ii,jj,k
+       real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1)
+       real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1)
+       real aa, bb,cc,dd
+       real pi
+
+       pi      = 2.*ASIN( 1. )
+
+
+
+c On repere les frontieres des cases :
+c =================================== 
+c
+c Attention, on ruse avec des latitudes = 90 deg au pole.
+
+
+c  ANcienne grile
+c  """"""""""""""
+      a(1) =   - rlonuo(imo+1)
+      b(1) = rlonuo(1)
+      do i=2,imo+1
+         a(i) = rlonuo(i-1)
+         b(i) =  rlonuo(i)
+      end do
+
+      d(1) = pi/2 
+      do j=1,jmo
+         c(j) = rlatvo(j) 
+         d(j+1) = rlatvo(j)
+      end do
+      c(jmo+1) = -pi/2 
+      
+
+c  Nouvelle grille
+c  """""""""""""""
+      an(1) =  - rlonun(imn+1)
+      bn(1) = rlonun(1)
+      do i=2,imn+1
+         an(i) = rlonun(i-1)
+         bn(i) =  rlonun(i)
+      end do
+
+      dn(1) = pi/2 
+      do j=1,jmn
+         cn(j) = rlatvn(j)
+         dn(j+1) = rlatvn(j)
+      end do
+      cn(jmn+1) = -pi/2 
+
+c Calcul de la surface des cases scalaires de la nouvelle grille
+c ==============================================================
+      do ii=1,imn + 1
+        do jj = 1,jmn+1
+               airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj)))
+        end do
+      end do
+
+c Calcul de la surface des intersections
+c ======================================
+
+c     boucle sur la nouvelle grille
+c     """"""""""""""""""""""""""""
+      ktotal = 0
+      do jj = 1,jmn+1
+       do j=1, jmo+1
+          if((cn(jj).lt.d(j)).and.(dn(jj).gt.c(j)))then
+              do ii=1,imn + 1
+                do i=1, imo +1
+                    if (  ((an(ii).lt.b(i)).and.(bn(ii).gt.a(i)))
+     &        .or. ((an(ii).lt.b(i)-2*pi).and.(bn(ii).gt.a(i)-2*pi)
+     &             .and.(b(i)-2*pi.lt.-pi) )
+     &        .or. ((an(ii).lt.b(i)+2*pi).and.(bn(ii).gt.a(i)+2*pi)
+     &             .and.(a(i)+2*pi.gt.pi) )
+     &                     )then
+                      ktotal = ktotal +1
+                      iik(ktotal) =ii
+                      jjk(ktotal) =jj
+                      ik(ktotal) =i
+                      jk(ktotal) =j
+
+                      dd = min(d(j), dn(jj))
+                      cc = cn(jj)
+                      if (cc.lt. c(j))cc=c(j)
+                      if((an(ii).lt.b(i)-2*pi).and.
+     &                  (bn(ii).gt.a(i)-2*pi)) then 
+                          bb = min(b(i)-2*pi,bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)-2*pi) aa=a(i)-2*pi
+                      else if((an(ii).lt.b(i)+2*pi).and.
+     &                       (bn(ii).gt.a(i)+2*pi)) then
+                          bb = min(b(i)+2*pi,bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)+2*pi) aa=a(i)+2*pi
+                      else 
+                          bb = min(b(i),bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)) aa=a(i)
+                      end if
+                      intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc))
+                     end if
+                end do
+               end do
+             end if
+         end do
+       end do       
+
+
+
+c     TEST  INFO
+c     DO k=1,ktotal 
+c      ii = iik(k) 
+c      jj = jjk(k)
+c      i = ik(k)
+c      j = jk(k)
+c      if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then
+c      if (jj.eq.2.and.(ii.eq.1))then
+c          write(*,*) '**************** jj=',jj,'ii=',ii
+c          write(*,*) 'i,j =',i,j
+c          write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj)
+c          write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j)
+c          write(*,*) 'intersec(k)',intersec(k)
+c          write(*,*) 'airen(ii,jj)=',airen(ii,jj)
+c      end if
+c     END DO 
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/iniprint.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/iniprint.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/iniprint.h	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/initial0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/initial0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/initial0.F	(revision 984)
@@ -0,0 +1,12 @@
+!
+! $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: LMDZ4/tags/LF_20080728/libf/dyn3d/integrd.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/integrd.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/integrd.F	(revision 984)
@@ -0,0 +1,232 @@
+!
+! $Header$
+!
+      SUBROUTINE integrd
+     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
+     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold )
+
+      IMPLICIT NONE
+
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Incrementation des tendances dynamiques
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "logic.h"
+#include "temps.h"
+#include "serre.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nq
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nq)
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
+
+      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
+
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
+      REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
+      REAL p(ip1jmp1,llmp1)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+      REAL deltap( ip1jmp1,llm )
+
+      INTEGER  l,ij,iq
+
+      REAL SSUM
+
+c-----------------------------------------------------------------------
+
+      DO  l = 1,llm
+        DO  ij = 1,iip1
+         ucov(    ij    , l) = 0.
+         ucov( ij +ip1jm, l) = 0.
+         uscr(     ij      ) = 0.
+         uscr( ij +ip1jm   ) = 0.
+        ENDDO
+      ENDDO
+
+
+c    ............    integration  de       ps         ..............
+
+      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+
+      DO 2 ij = 1,ip1jmp1
+       pscr (ij)    = ps(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)
+   2  CONTINUE
+c
+      DO ij = 1,ip1jmp1
+        IF( ps(ij).LT.0. ) THEN
+         PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij)
+         STOP' dans integrd'
+        ENDIF
+      ENDDO
+c
+      DO  ij    = 1, iim
+       tppn(ij) = aire(   ij   ) * ps(  ij    )
+       tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+      ENDDO
+       tpn      = SSUM(iim,tppn,1)/apoln
+       tps      = SSUM(iim,tpps,1)/apols
+      DO ij   = 1, iip1
+       ps(   ij   )  = tpn
+       ps(ij+ip1jm)  = tps
+      ENDDO
+c
+c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+c
+      CALL pression ( ip1jmp1, ap, bp, ps, p )
+      CALL massdair (     p  , masse         )
+
+      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
+c
+
+c    ............   integration  de  ucov, vcov,  h     ..............
+
+      DO 10 l = 1,llm
+
+      DO 4 ij = iip2,ip1jm
+      uscr( ij )   =  ucov( ij,l )
+      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+   4  CONTINUE
+
+      DO 5 ij = 1,ip1jm
+      vscr( ij )   =  vcov( ij,l )
+      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+   5  CONTINUE
+
+      DO 6 ij = 1,ip1jmp1
+      hscr( ij )    =  teta(ij,l)
+      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) 
+     $                + dt * dteta(ij,l) / masse(ij,l)
+   6  CONTINUE
+
+c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
+      DO  ij   = 1, iim
+        tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+        tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+      ENDDO
+        tpn      = SSUM(iim,tppn,1)/apoln
+        tps      = SSUM(iim,tpps,1)/apols
+
+      DO ij   = 1, iip1
+        teta(   ij   ,l)  = tpn
+        teta(ij+ip1jm,l)  = tps
+      ENDDO
+c
+
+      IF(leapf)  THEN
+         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+      END IF
+
+  10  CONTINUE
+
+
+c
+c   .......  integration de   q   ......
+c
+c$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
+c$$$c
+c$$$       IF( forward. OR . leapf )  THEN
+c$$$        DO iq = 1,2
+c$$$        DO  l = 1,llm
+c$$$        DO ij = 1,ip1jmp1
+c$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
+c$$$     $                            finvmasse(ij,l)
+c$$$        ENDDO
+c$$$        ENDDO
+c$$$        ENDDO
+c$$$       ELSE
+c$$$         DO iq = 1,2
+c$$$         DO  l = 1,llm
+c$$$         DO ij = 1,ip1jmp1
+c$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
+c$$$         ENDDO
+c$$$         ENDDO
+c$$$         ENDDO
+c$$$
+c$$$       END IF
+c$$$c
+c$$$      ENDIF
+
+         DO l = 1, llm
+          DO ij = 1, ip1jmp1
+           deltap(ij,l) =  p(ij,l) - p(ij,l+1) 
+          ENDDO
+         ENDDO
+
+         CALL qminimum( q, nq, deltap )
+c
+c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+c
+
+      DO iq = 1, nq
+        DO l = 1, llm
+
+           DO ij = 1, iim
+             qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+             qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+           ENDDO
+             qpn  =  SSUM(iim,qppn,1)/apoln
+             qps  =  SSUM(iim,qpps,1)/apols
+
+           DO ij = 1, iip1
+             q(   ij   ,l,iq)  = qpn
+             q(ij+ip1jm,l,iq)  = qps
+           ENDDO
+
+        ENDDO
+      ENDDO
+
+
+         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+c
+c
+c     .....   FIN  de l'integration  de   q    .......
+
+15    continue
+
+c    .................................................................
+
+
+      IF( leapf )  THEN
+         CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+         CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+      END IF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inter_barx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inter_barx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inter_barx.F	(revision 984)
@@ -0,0 +1,218 @@
+!
+! $Header$
+!
+       SUBROUTINE inter_barx ( idatmax,xidat,fdat,imodmax,ximod,fmod ) 
+
+c      .... Auteurs :  Robert Sadourny ,  P. Le Van  .....
+c
+       IMPLICIT NONE
+c    ----------------------------------------------------------
+c        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
+c            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
+c    ----------------------------------------------------------
+c
+c     idat : indice du champ de donnees, de 1 a idatmax
+c     imod : indice du champ du modele,  de 1 a  imodmax
+c     fdat(idat) : champ de donnees (entrees)
+c     fmod(imod) : champ du modele (sorties)
+c     xidat(idat): abscisses des interfaces des mailles donnees
+c     ximod(imod): abscisses des interfaces des mailles modele
+c      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
+c      ( Les abscisses sont exprimes en degres)
+
+
+      INTEGER idatmax, imodmax
+      REAL xidat(idatmax),fdat(idatmax),ximod(imodmax),fmod(imodmax)
+
+c    ...  Variables locales ... 
+    
+      REAL xxid(idatmax+1), xxd(idatmax+1), fdd(idatmax+1)
+      REAL  fxd(idatmax+1), xchan(idatmax+1), fdchan(idatmax+1) 
+      REAL  xxim(imodmax)
+
+      REAL x0,xim0,dx,dxm
+      REAL chmin,chmax,pi
+
+      INTEGER imod,idat,i,ichang,id0,id1,nid,idatmax1
+      
+      pi = 2. * ASIN(1.)
+
+c  -----------------------------------------------------
+c   REDEFINITION DE L'ORIGINE DES ABSCISSES
+c    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
+c  -----------------------------------------------------
+      DO imod = 1,imodmax
+       xxim(imod) = ximod(imod)
+      ENDDO
+
+      CALL minmax( imodmax,xxim,chmin,chmax)
+       IF( chmax.LT.6.50 )   THEN
+c        PRINT  3
+c        PRINT *,'   conversion des longit. ximod (donnees en radians)'
+c     , ,' en degres  .' 
+c        PRINT  3
+        DO imod = 1, imodmax
+        xxim(imod) = xxim(imod) * 180./pi
+        ENDDO  
+       ENDIF
+
+      xim0 = xxim(imodmax) - 360.
+
+      DO imod = 1, imodmax
+       xxim(imod) = xxim(imod) - xim0
+      ENDDO
+
+      idatmax1 = idatmax +1
+
+      DO idat = 1, idatmax
+       xxd(idat) = xidat(idat)
+      ENDDO
+
+      CALL minmax( idatmax,xxd,chmin,chmax)
+       IF( chmax.LT.6.50 )  THEN
+c        PRINT  3
+c        PRINT *,'   conversion des longit. ximod (donnees en radians)'
+c     , ,' en degres  .' 
+c        PRINT  3
+        DO idat = 1, idatmax
+        xxd(idat) = xxd(idat) * 180./pi
+        ENDDO  
+       ENDIF
+
+      DO idat = 1, idatmax
+       xxd(idat) = MOD( xxd(idat) - xim0, 360. )
+       fdd(idat) = fdat (idat)
+      ENDDO
+c       PRINT *,' xxd redef. origine abscisses '
+c       PRINT 2,(xxd(i),i=1,idatmax)
+
+      DO i = 2, idatmax
+        IF( ( xxd(i) - xxd(i-1)).LT.0. )  THEN
+         ichang = i
+         GO TO 5
+        ENDIF
+      ENDDO
+      GO TO 6
+c
+c  ***  reorganisation  des longitudes entre 0. et 360. degres ****
+c
+ 5    nid = idatmax - ichang +1
+      DO i = 1, nid
+        xchan (i) = xxd(i+ichang -1 )
+        fdchan(i) = fdd(i+ichang -1 )
+      ENDDO
+       DO i=1,ichang -1
+        xchan (i+ nid) = xxd(i)
+        fdchan(i+nid) = fdd(i) 
+       ENDDO
+      DO i =1,idatmax
+       xxd(i) = xchan(i)
+       fdd(i) = fdchan(i)
+      ENDDO
+
+ 6    continue
+
+
+c  ------------------------------------------------
+c    translation des champs de donnees par rapport
+c    a la nouvelle origine, avec redondance de la
+c       maille a cheval sur les bords
+c -----------------------------------------------
+
+      id0 = 0
+      id1 = 0
+
+      DO idat = 1, idatmax
+       IF ( xxd( idatmax1- idat ).LT.360.)   GO TO 10
+       id1 = id1 + 1
+      ENDDO
+
+ 10   DO idat = 1, idatmax
+       IF (xxd(idat).GT.0.) GO TO 20
+       id0 = id0 + 1
+      END DO
+
+ 20   IF( id1.EQ.0 ) GO TO 30
+      DO idat = 1, id1
+       xxid(idat) = xxd(idatmax - id1 + idat) - 360.
+       fxd (idat) = fdd(idatmax - id1 + idat)     
+      END DO
+      DO idat = 1, idatmax - id1
+       xxid(idat + id1) = xxd(idat)
+       fxd (idat + id1) = fdd(idat)
+      END DO
+
+  30  IF(id0.EQ.0) GO TO 40
+      DO idat = 1, idatmax - id0
+       xxid(idat) = xxd(idat + id0)
+       fxd (idat) = fdd(idat + id0)
+      END DO
+
+      DO idat = 1, id0
+       xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
+       fxd  (idatmax - id0 + idat) =  fdd(idat)   
+      END DO
+      GO TO 50
+ 
+ 40   DO idat = 1, idatmax
+       xxid(idat)  = xxd(idat)
+       fxd (idat)  = fdd(idat)
+      ENDDO
+
+ 50   xxid(idatmax1) = xxid(1) + 360.
+      fxd (idatmax1) = fxd(1)
+
+c  ------------------------------------
+c   initialisation du champ du modele
+
+      DO imod = 1, imodmax
+       fmod(imod) = 0.
+      END DO
+ 
+c      PRINT *,' id0 id1 ',id0,id1
+c      PRINT *,' xxim apres translation  '
+c      PRINT 2,(xxim(i),i=1,imodmax)
+c      PRINT *,' xxid apres translation '
+c      PRINT 2,(xxid(i),i=1,idatmax)
+c ---------------------------------------
+c iteration
+
+      x0   = xim0
+      dxm  = 0.
+      imod = 1
+      idat = 1
+ 
+ 100  IF (xxim(imod).LT.xxid(idat)) THEN
+       dx   = xxim(imod) - x0
+       dxm  = dxm + dx
+       fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm
+       x0   = xxim(imod)
+       dxm  = 0.
+       imod = imod + 1
+       IF (imod.LE.imodmax) GO TO 100
+  
+      ELSE IF (xxim(imod).GT.xxid(idat)) THEN
+       dx   = xxid(idat) - x0
+       dxm  = dxm + dx
+       fmod(imod) = fmod(imod) + dx * fxd(idat)
+       x0   = xxid(idat)
+       idat = idat + 1
+       GO TO 100
+ 
+      ELSE
+       dx   = xxim(imod) - x0
+       dxm  = dxm + dx
+       fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm
+       x0   = xxim(imod)
+       dxm  = 0.
+       imod = imod + 1
+       idat = idat + 1
+       IF (imod.LE.imodmax) GO TO 100
+      END IF
+     
+
+3      FORMAT(1x,70(1h-))
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inter_barxy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inter_barxy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inter_barxy.F	(revision 984)
@@ -0,0 +1,59 @@
+!
+! $Header$
+!
+       SUBROUTINE inter_barxy ( interfd,jnterfd,dlonid,dlatid ,
+     ,        champ,imod,jmod,rlonimod,rlatimod, jsort,champint )
+
+c    Auteur :   P. Le Van
+c
+       INTEGER interfd,jnterfd,imod,jmod
+       REAL champ(interfd,jnterfd +1 ),dlonid(interfd),dlatid(jnterfd),
+     ,      champint(imod,jsort)
+       REAL rlonimod(imod),rlatimod(jmod)
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+       REAL champx(imod),champy(jnterfd +1,imod),chpn(imod),chps(imod)
+       REAL chhpn,chhps
+       REAL fmody(jjp1)
+c
+
+       DO j = 1, jnterfd + 1
+        CALL inter_barx( interfd, dlonid, champ( 1,j ),
+     ,                       imod, rlonimod , champx )
+         DO i = 1,imod
+           champy(j,i) = champx(i)
+         ENDDO
+       ENDDO
+
+       DO i = 1, imod
+        CALL inter_bary( jjm,jnterfd,dlatid,champy(1,i),
+     ,                     jmod ,rlatimod,  fmody     )
+          DO j = 1, jsort
+           champint(i,j) = fmody(j)
+          ENDDO
+       ENDDO
+
+       IF( jsort.EQ.jjp1)  THEN
+
+c   ....  Valeurs uniques  aux  poles ....
+c
+         DO i =  1,imod
+          chpn(i)  = aire( i,  1   ) * champint( i, 1   )
+          chps(i)  = aire( i, jjp1 ) * champint( i,jjp1 )
+         ENDDO
+          chhpn  = SSUM(imod,chpn,1)/apoln
+          chhps  = SSUM(imod,chps,1)/apols
+
+         DO i = 1, imod
+          champint( i,  1  ) = chhpn
+          champint( i, jjp1) = chhps
+         ENDDO
+c
+       ENDIF
+
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/inter_bary.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/inter_bary.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/inter_bary.F	(revision 984)
@@ -0,0 +1,135 @@
+!
+! $Header$
+!
+       SUBROUTINE inter_bary( jjm, jdatmax, yjdatt, fdatt  ,
+     ,                       jmodmax, yjmodd,  fmod      )
+c
+c    ...  Auteurs :  Robert Sadourny  , P. Le Van ...
+c
+       IMPLICIT NONE
+
+c  ----------------------------------------------------------
+c       INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES  .
+c         VERSION UNIDIMENSIONNELLE  ,    EN LATITUDE  .
+c  ----------------------------------------------------------
+c
+c     jdat : indice du champ de donnees, de 1 a jdatmax
+c     jmod : indice du champ du modele,  de 1 a jmodmax
+c     fdatt(jdatmax) : champ de donnees (entrees)
+c     yjdatt(jdatmax): ordonnees des interfaces des mailles donnees
+c     yjmodd(jmodmax): ordonnees des interfaces des mailles modele
+c     fmod(jmodmax)  : champ du modele  (sorties)
+c
+c      ( L'indice 1 correspond a l'interface maille 1 / maille 2)
+c      ( Les ordonnees sont exprimees en degres)
+c
+c     jdatmax = nb. d'interfaces  donnees =  nombre de donnees - 1 
+c     jmodmax = nb. d'interfaces  modele
+
+c     Si jmodmax = jjm , on veut interpoler sur les jjm+1 latitudes 
+c       rlatu   du modele ( lat.  des scalaires et de U ) 
+c
+c     Si jmodmax = jjp1 , on veut interpoler sur les jjm latitudes 
+c       rlatv du modele  ( lat.  de  V ) 
+
+c  ....  Arguments  en entree  .......
+
+       INTEGER jjm , jdatmax, jmodmax
+       REAL    yjdatt( jdatmax ) , fdatt( jdatmax +1 )
+       REAL    yjmodd( jmodmax )     
+
+c  ....  Arguments  en sortie  .......
+c
+       REAL    fmod( jmodmax + 1 )
+c
+c   ...... Variables locales  ......
+
+       INTEGER      jmods
+
+       REAL       yjdat ( jdatmax +1 ), fdat( jdatmax +1) 
+       REAL       fscrat( jdatmax +1 )
+       REAL       yjmod ( jmodmax +1 )
+       LOGICAL    decrois
+       SAVE       decrois
+c
+       REAL y0,dy,dym 
+       INTEGER jdat, jmod,i
+c
+
+        DO i = 1, jdatmax +1
+         fdat (i) = fdatt (i)
+        ENDDO
+
+       CALL ord_coord (  jdatmax , yjdatt(1), yjdat(1), decrois ) 
+
+       IF( decrois )   THEN
+         DO i = 1,jdatmax + 1
+          fscrat(i) = fdat(i)
+         ENDDO
+         DO i = 1, jdatmax + 1
+          fdat(i) = fscrat( jdatmax + 2 -i )
+         ENDDO
+
+       ENDIF
+
+       CALL ord_coordm (jmodmax,yjmodd(1),yjmod(1),jjm,jmods,decrois ) 
+c
+c      Initialisation des variables
+c    --------------------------------
+
+       DO jmod = 1, jmods
+        fmod(jmod) = 0.
+       END DO
+
+       y0    = 0.
+       dym   = 0.
+       jmod  = 1
+       jdat  = 1
+c  --------------------
+c      Iteration
+c  --------------------
+
+100    IF ( yjmod(jmod).LT.yjdat(jdat) ) THEN
+        dy         = yjmod(jmod) - y0
+        dym        = dym + dy
+        fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym
+        y0         = yjmod(jmod)
+        dym        = 0.
+        jmod       = jmod + 1
+        GO TO 100
+
+       ELSE IF ( yjmod(jmod).GT.yjdat(jdat) ) THEN
+        dy         = yjdat(jdat) - y0
+        dym        = dym + dy
+        fmod(jmod) = fmod(jmod) + dy * fdat(jdat)
+        y0         = yjdat(jdat)
+        jdat       = jdat + 1
+
+       GO TO 100
+
+       ELSE
+        dy         = yjmod(jmod) - y0
+        dym        = dym + dy
+        fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym
+        y0         = yjmod(jmod)
+        dym        = 0.
+        jmod       = jmod + 1
+        jdat       = jdat + 1
+
+        IF ( jmod.LE.jmods ) GO TO 100
+       END IF
+c   ---------------------------------------------
+c    Le test de fin suppose que l'interface 0
+c    est commune aux deux grilles yjdat et yjmod.
+c   ----------------------------------------------
+       IF( decrois )  THEN
+         DO i = 1,jmods
+          fscrat(i) = fmod(i)
+         ENDDO
+         DO i = 1, jmods
+          fmod(i) = fscrat( jmods + 1 -i )
+         ENDDO
+       ENDIF
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/interp_horiz.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/interp_horiz.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/interp_horiz.F	(revision 984)
@@ -0,0 +1,154 @@
+c
+c $Header$
+c
+      subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm,
+     &  rlonuo,rlatvo,rlonun,rlatvn)  
+
+c===========================================================
+c  Interpolation Horizontales des variables d'une grille LMDZ
+c (des points SCALAIRES au point SCALAIRES)
+c  dans une autre grille LMDZ en conservant la quantite
+c  totale pour les variables intensives (/m2) : ex : Pression au sol
+c
+c Francois Forget (01/1995)
+c===========================================================
+
+      IMPLICIT NONE 
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+        
+       integer imo, jmo ! dimensions ancienne grille (input)
+       integer imn,jmn  ! dimensions nouvelle grille (input)
+
+       real rlonuo(imo+1)     !  Latitude et
+       real rlatvo(jmo)       !  longitude des
+       real rlonun(imn+1)     !  bord des 
+       real rlatvn(jmn)     !  cases "scalaires" (input)
+
+       integer lm ! dimension verticale (input)
+       real varo (imo+1, jmo+1,lm) ! var dans l'ancienne grille (input)
+       real varn (imn+1,jmn+1,lm) ! var dans la nouvelle grille (output)
+
+c Autres variables
+c """"""""""""""""
+       real airetest(imn+1,jmn+1)
+       integer ii,jj,l
+
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+c    Info sur les ktotal intersection entre les cases new/old grille
+       integer kllm, k, ktotal
+       parameter (kllm = 400*200*10)
+       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
+       real intersec(kllm)
+       real R
+       real totn, tots
+
+       logical firstcall, firsttest, aire_ok
+       save firsttest
+       data firsttest /.true./
+       data aire_ok /.true./
+
+       
+
+
+
+c initialisation
+c --------------
+c Si c'est le premier appel, on prepare l'interpolation
+c en calculant pour chaque case autour d'un point scalaire de la
+c nouvelle grille, la surface  de intersection avec chaque
+c    case de l'ancienne grille.
+
+
+        call iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &          ktotal,iik,jjk,jk,ik,intersec,airen)
+
+      do l=1,lm
+       do jj =1 , jmn+1
+        do ii=1, imn+1
+          varn(ii,jj,l) =0.
+        end do
+       end do
+      end do 
+       
+c Interpolation horizontale
+c -------------------------
+c boucle sur toute les ktotal intersections entre les cases
+c de l'ancienne et la  nouvelle grille
+c
+      PRINT *, 'ktotal 1 = ', ktotal
+     
+      do k=1,ktotal
+        do l=1,lm
+         varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l) 
+     &        + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k))
+        end do
+      end do
+
+c Une seule valeur au pole pour les variables ! :
+c -----------------------------------------------
+       do l=1, lm
+         totn =0.
+         tots =0.
+           do ii =1, imn+1
+             totn = totn + varn(ii,1,l)
+             tots = tots + varn (ii,jmn+1,l)
+           end do 
+           do ii =1, imn+1
+             varn(ii,1,l) = totn/float(imn+1)
+             varn(ii,jmn+1,l) = tots/float(imn+1)
+           end do 
+       end do
+           
+
+c---------------------------------------------------------------
+c  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST 
+!!       if (.not.(firsttest)) goto 99
+!!       firsttest = .false.
+!! !     write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:'
+!!       do jj =1 , jmn+1
+!!         do ii=1, imn+1
+!!           airetest(ii,jj) =0.
+!!         end do
+!!       end do 
+!!       PRINT *, 'ktotal = ', ktotal
+!!       PRINT *, 'jmn+1 =', jmn+1, 'imn+1', imn+1
+!! 
+!!       do k=1,ktotal
+!!          airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k) 
+!!       end DO
+!! 
+!! 
+!!       PRINT *, 'fin boucle'
+!!       do jj =1 , jmn+1
+!!        do ii=1, imn+1
+!!          r = airen(ii,jj)/airetest(ii,jj)
+!!          if ((r.gt.1.001).or.(r.lt.0.999)) then
+!! !             write (*,*) '********** PROBLEME D'' AIRES !!!',
+!! !     &                   ' DANS L''INTERPOLATION HORIZONTALE'
+!! !             write(*,*)'ii,jj,airen,airetest',
+!! !     &          ii,jj,airen(ii,jj),airetest(ii,jj)
+!!              aire_ok = .false.
+!!          end if
+!!        end do
+!!       end do
+!! !      if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK'
+!!  99   continue
+
+c FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST
+c---------------------------------------------------------------
+
+
+
+
+
+
+
+
+        return
+        end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/interpost.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/interpost.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/interpost.F	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+        subroutine interpost(q,qppm)
+
+       implicit none
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c Arguments   
+      real   q(iip1,jjp1,llm)
+      real   qppm(iim,jjp1,llm)
+c Local
+      integer l,i,j
+  
+c RE-INVERSION DES NIVEAUX
+c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+c On passe donc des niveaux de Lin à ceux du LMDZ
+           
+        do l=1,llm
+          do j=1,jjp1
+             do i=1,iim
+                 q(i,j,l)=qppm(i,j,llm-l+1)
+             enddo
+          enddo
+         enddo
+            
+c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
+
+         do l=1,llm
+           do j=1,jjp1
+            q(iip1,j,l)=q(1,j,l)
+           enddo
+         enddo
+  
+      
+       return
+
+       end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/interpre.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/interpre.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/interpre.F	(revision 984)
@@ -0,0 +1,132 @@
+!
+! $Header$
+!
+       subroutine interpre(q,qppm,w,fluxwppm,masse,
+     s            apppm,bpppm,massebx,masseby,pbaru,pbarv,
+     s            unatppm,vnatppm,psppm)
+
+       implicit none
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+c---------------------------------------------------
+c Arguments     
+      real   apppm(llm+1),bpppm(llm+1)
+      real   q(iip1,jjp1,llm),qppm(iim,jjp1,llm)
+c---------------------------------------------------
+      real   masse(iip1,jjp1,llm) 
+      real   massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)      
+      real   w(iip1,jjp1,llm+1)
+      real   fluxwppm(iim,jjp1,llm)
+      real   pbaru(iip1,jjp1,llm )
+      real   pbarv(iip1,jjm,llm)
+      real   unatppm(iim,jjp1,llm)
+      real   vnatppm(iim,jjp1,llm)
+      real   psppm(iim,jjp1)
+c---------------------------------------------------
+c Local
+      real   vnat(iip1,jjp1,llm)
+      real   unat(iip1,jjp1,llm)
+      real   fluxw(iip1,jjp1,llm)
+      real   smass(iip1,jjp1)
+c----------------------------------------------------
+      integer l,ij,i,j
+
+c       CALCUL DE LA PRESSION DE SURFACE
+c       Les coefficients ap et bp sont passés en common 
+c       Calcul de la pression au sol en mb optimisée pour 
+c       la vectorialisation
+                   
+         do j=1,jjp1
+             do i=1,iip1
+                smass(i,j)=0.
+             enddo
+         enddo
+
+         do l=1,llm
+             do j=1,jjp1
+                 do i=1,iip1
+                    smass(i,j)=smass(i,j)+masse(i,j,l)
+                 enddo
+             enddo
+         enddo
+      
+         do j=1,jjp1
+             do i=1,iim
+                 psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01
+             end do
+         end do                        
+       
+c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS
+c Le programme ppm3d travaille avec les composantes
+c de vitesse et pas les flux, on doit donc passer de l'un à l'autre
+c Dans le même temps, on fait le changement d'orientation du vent en v
+      do l=1,llm
+          do j=1,jjm
+              do i=1,iip1
+                  vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)             
+              enddo
+          enddo
+          do  i=1,iim
+          vnat(i,jjp1,l)=0.
+          enddo
+          do j=1,jjp1
+              do i=1,iip1
+                  unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)
+              enddo
+          enddo
+      enddo
+              
+c CALCUL DU FLUX MASSIQUE VERTICAL
+c Flux en l=1 (sol) nul
+      fluxw=0.        
+      do l=1,llm
+           do j=1,jjp1
+              do i=1,iip1              
+               fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j)
+C               print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l),
+C     c                      'w(i,j,l)=',w(i,j,l)
+              enddo
+           enddo
+      enddo
+      
+c INVERSION DES NIVEAUX
+c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+c On passe donc des niveaux du LMDZ à ceux de Lin
+     
+      do l=1,llm+1
+          apppm(l)=ap(llm+2-l)
+          bpppm(l)=bp(llm+2-l)         
+      enddo 
+     
+      do l=1,llm
+          do j=1,jjp1
+             do i=1,iim     
+                 unatppm(i,j,l)=unat(i,j,llm-l+1)
+                 vnatppm(i,j,l)=vnat(i,j,llm-l+1)
+                 fluxwppm(i,j,l)=fluxw(i,j,llm-l+1)
+                 qppm(i,j,l)=q(i,j,llm-l+1)                              
+             enddo
+          enddo                                
+      enddo
+   
+      return
+      end
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ismax.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ismax.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ismax.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/ismin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ismin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ismin.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/juldate.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/juldate.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/juldate.F	(revision 984)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+	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 real (a-h,o-z)
+	frac=((os/60.+om)/60.+oh)/24.
+	ojou=dfloat(ijou)+frac
+	    year=dfloat(ian)
+	    rmon=dfloat(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: LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien.F	(revision 984)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien ( klevel, teta, divgra )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c    ....     calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .........      variables  en arguments   ..............
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    .......................................................
+
+
+c
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+      CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_gam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_gam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_gam.F	(revision 984)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam ,
+     *                        unsapolnga, unsapolsga, teta, divgra )
+
+c  P. Le Van
+c
+c   ************************************************************
+c
+c      ....   calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c    klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    ............     variables  en arguments    ..........
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
+     *     unsapolnga, unsapolsga
+c
+c    ...........    variables  locales    .................
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    ......................................................
+
+c
+c
+c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+c
+      CALL   grad ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_rot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_rot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_rot.F	(revision 984)
@@ -0,0 +1,39 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
+c
+c    P. Le Van
+c
+c   ************************************************************
+c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+c   ************************************************************
+c
+c     klevel et rotin  sont des arguments  d'entree pour le s-prog
+c      rotout           est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c 
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+c   ........................................................
+c
+c
+      CALL  filtreg ( rotin ,   jjm, klevel,   2, 1, .FALSE., 1 )
+
+      CALL   nxgrad ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_rotgam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_rotgam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/laplacien_rotgam.F	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c   ........................................................
+c
+c
+
+      CALL   nxgrad_gam ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil ( klevel, ghx  ,   ghy , rotout )
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jm
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/leapfrog.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/leapfrog.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/leapfrog.F	(revision 984)
@@ -0,0 +1,674 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,nq,q,clesphy0,
+     &                    time_0)
+
+
+cIM : pour sortir les param. du modele dans un fis. netcdf 110106
+      USE IOIPSL 
+
+      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 shema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (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 "advtrac.h"
+c#include "tracstoke.h"
+
+#include "academic.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! #include "clesphys.h"
+
+      integer nq
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      real zqmin,zqmax
+      INTEGER nbetatmoy, nbetatdem,nbetat
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu 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
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
+
+c   variables dynamiques au pas -1
+      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1)
+      REAL massem1(ip1jmp1,llm)
+
+c   tendances dynamiques
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqmx),dp(ip1jmp1)
+
+c   tendances de la dissipation
+      REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
+      REAL dtetadis(ip1jmp1,llm)
+
+c   tendances physiques
+      REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
+      REAL dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1)
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL tppn(iim),tpps(iim),tpn,tps
+c
+      INTEGER itau,itaufinp1,iav
+      INTEGER*4  iday ! jour julien
+      REAL       time ! Heure de la journee en fraction d'1 jour
+
+      REAL  SSUM
+      REAL time_0 , finvmaold(ip1jmp1,llm)
+
+cym      LOGICAL  lafin
+      LOGICAL :: lafin=.false.
+      INTEGER ij,iq,l
+      INTEGER ik
+
+      real time_step, t_wrt, t_ops
+
+      REAL rdayvrai,rdaym_ini
+      LOGICAL first,callinigrads
+cIM : pour sortir les param. du modele dans un fis. netcdf 110106
+      save first
+      data first/.true./
+      real dt_cum, zjulian
+      character*10 infile
+      integer zan, tau0, thoriid
+      integer nid_ctesGCM
+      save nid_ctesGCM
+      real degres
+      real rlong(iip1), rlatg(jjp1)
+      real zx_tmp_2d(iip1,jjp1)
+      integer ndex2d(iip1*jjp1)
+      logical ok_sync
+      parameter (ok_sync = .true.) 
+
+      data callinigrads/.true./
+      character*10 string10
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+      REAL :: flxw(ip1jmp1,llm)  ! flux de masse verticale
+
+c+jld variables test conservation energie
+      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 dtetaecdt(ip1jmp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm)
+      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+      CHARACTER*15 ztit
+!IM   INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+!IM   SAVE      ip_ebil_dyn
+!IM   DATA      ip_ebil_dyn/0/
+c-jld 
+
+      character*80 dynhist_file, dynhistave_file
+      character*20 modname
+      character*80 abort_message
+
+C Calendrier
+      LOGICAL true_calendar
+      PARAMETER (true_calendar = .false.)
+
+      logical dissip_conservative
+      save dissip_conservative
+      data dissip_conservative/.true./
+
+      LOGICAL prem
+      save prem
+      DATA prem/.true./
+      INTEGER testita
+      PARAMETER (testita = 9)
+
+      integer itau_w   ! pas de temps ecriture = itap + itau_phy
+
+
+      itaufin   = nday*day_step
+      itaufinp1 = itaufin +1
+
+
+      itau = 0
+      iday = day_ini+itau/day_step
+      time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+         IF(time.GT.1.) THEN
+          time = time-1.
+          iday = iday+1
+         ENDIF
+
+
+c-----------------------------------------------------------------------
+c   On initialise la pression et la fonction d'Exner :
+c   --------------------------------------------------
+
+      dq=0.
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+
+   1  CONTINUE
+
+
+#ifdef CPP_IOIPSL
+      if (ok_guide.and.(itaufin-itau-1)*dtvr.gt.21600) then
+        call guide(itau,ucov,vcov,teta,q,masse,ps)
+      else
+        IF(prt_level>9)WRITE(*,*)'attention on ne guide pas les ',
+     .    '6 dernieres heures'
+      endif
+#endif
+c
+c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+c       CALL  test_period ( ucov,vcov,teta,q,p,phis )
+c       PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+c     ENDIF 
+c
+      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+
+c   ...    P.Le Van .26/04/94  ....
+
+      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+
+   2  CONTINUE
+
+c-----------------------------------------------------------------------
+
+c   date:
+c   -----
+
+
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+
+      IF( purmats ) THEN
+         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
+         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward 
+     s          .and. iflag_phys.NE.0                 ) apphys = .TRUE.
+      ELSE
+         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
+         IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.NE.0) apphys=.TRUE.
+      END IF
+
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+      CALL caldyn 
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time+iday-day_ini )
+
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+
+      IF( forward. OR . leapf )  THEN
+
+         CALL caladvtrac(q,pbaru,pbarv,
+     *        p, masse, dq,  teta,
+     .        flxw, pk)
+         
+         IF (offline) THEN
+Cmaf stokage du flux de masse pour traceurs OFF-LINE
+
+#ifdef CPP_IOIPSL
+           CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     .   dtvr, itau)
+#endif
+
+
+         ENDIF
+c
+      ENDIF
+
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+
+       CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
+     $              finvmaold                                    )
+
+
+c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+c
+c-----------------------------------------------------------------------
+c   calcul des tendances physiques:
+c   -------------------------------
+c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+c
+       IF( purmats )  THEN
+          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+       ELSE
+          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
+       ENDIF
+c
+c
+       IF( apphys )  THEN
+c
+c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+c
+
+         CALL pression (  ip1jmp1, ap, bp, ps,  p      )
+         CALL exner_hyb(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
+
+           rdaym_ini  = itau * dtvr / daysec
+           rdayvrai   = rdaym_ini  + day_ini
+
+
+c rajout debug
+c       lafin = .true.
+
+
+c   Inbterface avec les routines de phylmd (phymars ... )
+c   -----------------------------------------------------
+
+#ifdef CPP_PHYS
+c+jld
+
+c  Diagnostique de conservation de l'énergie : initialisation
+      IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil dyn'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+      ENDIF 
+c-jld
+cIM : pour sortir les param. du modele dans un fis. netcdf 110106
+      IF (first) THEN
+       first=.false.
+#include "ini_paramLMDZ_dyn.h"
+      ENDIF
+c
+#include "write_paramLMDZ_dyn.h"
+c
+
+        CALL calfis( nq, lafin ,rdayvrai,time  ,
+     $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+     $               du,dv,dteta,dq,
+     $               flxw,
+     $               clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi  )
+
+c      ajout des tendances physiques:
+c      ------------------------------
+          CALL addfi( nqmx, dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps ,
+     $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+c
+c  Diagnostique de conservation de l'énergie : difference
+      IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil phys'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+      ENDIF 
+#else
+
+c   Calcul academique de la physique = Rappel Newtonien + fritcion 
+c   --------------------------------------------------------------
+       teta(:,:)=teta(:,:)
+     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+       call friction(ucov,vcov,iphysiq*dtvr)
+
+#endif
+
+c-jld
+       ENDIF
+
+        CALL pression ( ip1jmp1, ap, bp, ps, p                  )
+        CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+
+
+c-----------------------------------------------------------------------
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+      IF(apdiss) THEN
+
+
+c   calcul de l'energie cinetique avant dissipation
+        call covcont(llm,ucov,vcov,ucont,vcont)
+        call enercin(vcov,ucov,vcont,ucont,ecin0)
+
+c   dissipation
+        CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+        ucov=ucov+dudis
+        vcov=vcov+dvdis
+c       teta=teta+dtetadis
+
+
+c------------------------------------------------------------------------
+        if (dissip_conservative) then
+C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+C       lors de la dissipation
+            call covcont(llm,ucov,vcov,ucont,vcont)
+            call enercin(vcov,ucov,vcont,ucont,ecin)
+            dtetaecdt= (ecin0-ecin)/ pk
+c           teta=teta+dtetaecdt
+            dtetadis=dtetadis+dtetaecdt
+        endif
+        teta=teta+dtetadis
+c------------------------------------------------------------------------
+
+
+c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+c
+
+        DO l  =  1, llm
+          DO ij =  1,iim
+           tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+           tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+          ENDDO
+           tpn  = SSUM(iim,tppn,1)/apoln
+           tps  = SSUM(iim,tpps,1)/apols
+
+          DO ij = 1, iip1
+           teta(  ij    ,l) = tpn
+           teta(ij+ip1jm,l) = tps
+          ENDDO
+        ENDDO
+
+        DO ij =  1,iim
+          tppn(ij)  = aire(  ij    ) * ps (  ij    )
+          tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+        ENDDO
+          tpn  = SSUM(iim,tppn,1)/apoln
+          tps  = SSUM(iim,tpps,1)/apols
+
+        DO ij = 1, iip1
+          ps(  ij    ) = tpn
+          ps(ij+ip1jm) = tps
+        ENDDO
+
+
+      END IF
+
+c ajout debug
+c              IF( lafin ) then  
+c                abort_message = 'Simulation finished'
+c                call abort_gcm(modname,abort_message,0)
+c              ENDIF
+        
+c   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+
+c   preparation du pas d'integration suivant  ......
+
+      IF ( .NOT.purmats ) THEN
+c       ........................................................
+c       ..............  schema matsuno + leapfrog  ..............
+c       ........................................................
+
+            IF(forward. OR. leapf) THEN
+              itau= itau + 1
+              iday= day_ini+itau/day_step
+              time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+                IF(time.GT.1.) THEN
+                  time = time-1.
+                  iday = iday+1
+                ENDIF
+            ENDIF
+
+
+            IF( itau. EQ. itaufinp1 ) then  
+c              write(79,*) 'ucov',ucov
+c              write(80,*) 'vcov',vcov
+c              write(81,*) 'teta',teta
+c              write(82,*) 'ps',ps
+c              write(83,*) 'q',q
+c              WRITE(85,*) 'q1 = ',q(:,:,1)
+c              WRITE(86,*) 'q3 = ',q(:,:,3)
+
+              abort_message = 'Simulation finished'
+
+              call abort_gcm(modname,abort_message,0)
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+#ifdef CPP_IOIPSL
+              CALL writedynav(histaveid, nqmx, itau,vcov ,
+     ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+               call bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+#endif
+
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   ecriture de la bande histoire:
+c   ------------------------------
+
+            IF( MOD(itau,iecri         ).EQ.0) THEN
+c           IF( MOD(itau,iecri*day_step).EQ.0) THEN
+
+               nbetat = nbetatdem
+       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi        )
+        unat=0.
+        do l=1,llm
+           unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm)
+           vnat(:,l)=vcov(:,l)/cv(:)
+        enddo
+#ifdef CPP_IOIPSL
+c        CALL writehist(histid,histvid, nqmx,itau,vcov, 
+c     s                       ucov,teta,phi,q,masse,ps,phis)
+#else
+#include "write_grads_dyn.h"
+#endif
+
+
+            ENDIF
+
+            IF(itau.EQ.itaufin) THEN
+
+
+#ifdef CPP_IOIPSL
+       CALL dynredem1("restart.nc",0.0,
+     ,                     vcov,ucov,teta,q,nqmx,masse,ps)
+#endif
+
+              CLOSE(99)
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2
+                   END IF
+            ELSE
+
+c      ......   pas leapfrog  .....
+
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF
+
+      ELSE
+
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+
+             itau =  itau + 1
+             iday = day_ini+itau/day_step
+             time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+
+                  IF(time.GT.1.) THEN
+                   time = time-1.
+                   iday = iday+1
+                  ENDIF
+
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then  
+                 abort_message = 'Simulation finished'
+                 call abort_gcm(modname,abort_message,0)
+               ENDIF
+               GO TO 2
+
+            ELSE
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+#ifdef CPP_IOIPSL
+              CALL writedynav(histaveid, nqmx, itau,vcov ,
+     ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+               call bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+#endif
+
+            ENDIF
+
+               IF(MOD(itau,iecri         ).EQ.0) THEN
+c              IF(MOD(itau,iecri*day_step).EQ.0) THEN
+                  nbetat = nbetatdem
+       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi       )
+        unat=0.
+        do l=1,llm
+           unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm)
+           vnat(:,l)=vcov(:,l)/cv(:)
+        enddo
+#ifdef CPP_IOIPSL
+c       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+c    ,                           ucov,teta,phi,q,masse,ps,phis)
+#else
+#include "write_grads_dyn.h"
+#endif
+
+
+               ENDIF
+
+#ifdef CPP_IOIPSL
+                 IF(itau.EQ.itaufin)
+     . CALL dynredem1("restart.nc",0.0,
+     .                     vcov,ucov,teta,q,nqmx,masse,ps)
+#endif
+
+                 forward = .TRUE.
+                 GO TO  1
+
+            ENDIF
+
+      END IF
+
+      STOP
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/limit_netcdf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/limit_netcdf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/limit_netcdf.F	(revision 984)
@@ -0,0 +1,1285 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque, pctsrf)
+      USE dimphy
+      IMPLICIT none
+c
+c-------------------------------------------------------------
+C Author : L. Fairhead
+C Date   : 27/01/94
+C Objet  : Construction des fichiers de conditions aux limites
+C          pour le nouveau
+C          modele a partir de fichiers de climatologie. Les deux
+C          grilles doivent etre regulieres
+c
+c Modifie par z.x.li (le23mars1994)
+c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
+c                         pour lecture netcdf dans LMDZ.3.3
+c Modifie par P;Le Van  ,  juillet 2001
+c-------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "comconst.h"
+cy#include "dimphy.h"
+#include "indicesol.h"
+c
+c-----------------------------------------------------------------------
+      LOGICAL interbar, extrap, oldice
+
+      REAL phy_nat(klon,360), phy_nat0(klon)
+      REAL phy_alb(klon,360)
+      REAL phy_sst(klon,360)
+      REAL phy_bil(klon,360)
+      REAL phy_rug(klon,360)
+      REAL phy_ice(klon)
+c
+      real pctsrf_t(klon,nbsrf,360)
+      real pctsrf(klon,nbsrf)
+      REAL verif
+
+      REAL masque(iip1,jjp1)
+      REAL mask(iim,jjp1)
+CPB
+C newlmt indique l'utilisation de la sous-maille fractionnelle
+C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3)
+      LOGICAL newlmt, fracterre
+      PARAMETER(newlmt=.TRUE.)
+      PARAMETER(fracterre = .TRUE.) 
+
+C Declarations pour le champ de depart
+      INTEGER imdep, jmdep,lmdep
+      INTEGER  tbid
+      PARAMETER ( tbid = 60 )        ! >52 semaines
+      REAL  timecoord(tbid)
+c
+      REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:)
+      REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:)
+      REAL , ALLOCATABLE :: dlon(:), dlat(:)
+      REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:)
+      REAL , ALLOCATABLE :: champ_msk(:), champ(:)
+      REAL , ALLOCATABLE :: work(:,:)
+
+      CHARACTER*25 title
+
+C Declarations pour le champ interpole 2D
+      REAL champint(iim,jjp1)
+      real chmin,chmax
+
+C Declarations pour le champ interpole 3D
+      REAL champtime(iim,jjp1,tbid)
+      REAL timeyear(tbid)
+      REAL champan(iip1,jjp1,366)
+
+C Declarations pour l'inteprolation verticale
+      REAL ax(tbid), ay(tbid)
+      REAL by
+      REAL yder(tbid)
+
+
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+CPB
+      INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC
+
+      INTEGER i, j, k, l, ji
+c declarations pour lecture glace de mer
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+
+c Diverses variables locales
+      REAL time
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+
+      INTEGER          longcles
+      PARAMETER      ( longcles = 20 )
+      REAL  clesphy0 ( longcles      )
+#include "serre.h"
+      INTEGER ncid,varid,ndimid(4),dimid
+      character*30 namedim
+      CHARACTER*80 :: varname
+
+cIM28/02/2002 <== PM
+      REAL tmidmonth(12)
+      SAVE tmidmonth
+      DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/
+
+c initialisations:
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+
+      pi     = 4. * ATAN(1.)
+      rad    = 6 371 229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      dtvr    = daysec/FLOAT(day_step)
+      CALL inigeom
+c
+C Traitement du relief au sol
+c
+      write(*,*) 'Traitement du relief au sol pour fabriquer masque'
+      ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
+
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ALLOCATE( lonmsk_ini(imdep) )
+      ALLOCATE(   dlon_msk(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini)
+#endif
+
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ALLOCATE( latmsk_ini(jmdep) )
+      ALLOCATE(   dlat_msk(jmdep) )
+      ALLOCATE(  champ_msk(imdep*jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini)
+#endif
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
+#endif
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      title='RELIEF'
+
+      CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini,
+     . dlon_msk, dlat_msk, champ_msk, interbar  )
+
+      DO i = 1, iim
+      DO j = 1, jjp1
+         mask(i,j) = masque(i,j)
+      ENDDO
+      ENDDO
+      WRITE(*,*) 'MASK:'
+      WRITE(*,'(96i1)')INT(mask)     
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de la rugosite
+c
+      PRINT*, 'Traitement de la rugosite'
+      ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlon_ini(imdep) )
+      ALLOCATE(     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlat_ini(jmdep) )
+      ALLOCATE(     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      ALLOCATE( champ(imdep*jmdep) )
+
+      DO  200 l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+         print*,dimfirst,dimlast
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF 
+   
+        title = 'Rugosite Amip '
+c
+        CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                      dlon, dlat, champ, interbar          )
+
+       IF ( interbar )   THEN
+         DO j = 1, imdep * jmdep
+           champ(j) = LOG(champ(j))
+         ENDDO
+
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour la rugosite $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+        CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ ,
+     ,                  iim,jjm,rlonu,rlatv, jjp1,champint )
+         DO j=1,jjp1
+          DO i=1,iim
+           champint(i,j)=EXP(champint(i,j))
+          ENDDO
+         ENDDO
+
+         DO j = 1, jjp1
+           DO i = 1, iim
+             IF(NINT(mask(i,j)).NE.1)  THEN
+               champint( i,j ) = 0.001
+             ENDIF
+           ENDDO
+         ENDDO
+      ELSE
+         CALL rugosite(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint, mask)
+      ENDIF
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+200      CONTINUE
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+
+      PRINT 222, timeyear
+222   FORMAT(2x,' Time year ',10f6.1)
+c
+        
+      PRINT*, 'Interpolation temporelle dans l annee'
+
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Rugosite au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+c
+c
+C Traitement de la glace oceanique
+c
+      PRINT*, 'Traitement de la glace oceanique'
+
+      ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) THEN
+        ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid)
+        if (ierr.ne.0) THEN
+          print *, NF_STRERROR(ierr)
+          STOP
+        endif
+      ENDIF
+
+cIM22/02/2002
+cIM07/03/2002 AMIP.nc & amip79to95.nc
+cIM   ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid)
+cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc
+      ierr = NF_INQ_VARID(ncid,'sicbcs',varid)
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr),'sicbcs'
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlon_ini(imdep) )
+      ALLOCATE (     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlat_ini(jmdep) )
+      ALLOCATE (     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, lmdep
+cIM28/02/2002
+cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
+c               Ici on suppose qu'on a 12 mois (de 30 jours).
+      IF (lmdep.NE.12) THEN
+          print *, 'Unknown AMIP file: not 12 months ?'
+          STOP
+       ENDIF
+cIM28/02/2002
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      ALLOCATE ( champ(imdep*jmdep) )
+
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+ 
+         title = 'Sea-ice Amip '
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                        dlon, dlat, champ, interbar          )
+c
+      IF( oldice )  THEN
+                 CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint )
+      ELSEIF ( interbar )  THEN
+       IF( l.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour Sea-ice Amip  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+       ENDIF
+cIM07/03/2002 
+cIM22/02/2002 : Sea-ice Amip entre 0. et 1.
+cIM    PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' 
+cIM   DO j = 1, imdep * jmdep
+cIM28/02/2002 <==PM         champ(j) = champ(j)/100.
+cIM14/03/2002      champ(j) = max(0.0,(min(1.0, (champ(j)/100.) )))
+cIM      champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) )))
+cIM   ENDDO
+cIM22/02/2002
+         CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
+     ,     champ, iim, jjm, rlonu, rlatv, jjp1, champint )
+      ELSE
+         CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint )
+      ENDIF
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+cIM28/02/2002 <== PM  timeyear(l) = timecoord(l)
+cIM      timeyear(l) = timecoord(l)
+cIM07/03/2002      
+         timeyear(l) = tmidmonth(l)
+      ENDDO
+      PRINT 222,  timeyear
+c
+      PRINT*, 'Interpolation temporelle'
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Sea ice au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+cIM14/03/2002 : Sea-ice Amip entre 0. et 1.
+      PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc '
+      DO k = 1, 360
+      DO j = 1, jjp1
+      DO i = 1, iim
+        champan(i, j, k) = 
+     $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.))))
+      ENDDO
+        champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+cIM14/03/2002
+
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_ice)
+        IF ( newlmt) THEN
+
+CPB  en attendant de mettre fraction de terre
+c
+          WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1.
+          WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0.
+c 
+          IF (fracterre ) THEN
+c            WRITE(*,*) 'passe dans cas fracterre' 
+            pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter)
+            pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic)
+            pctsrf_t(1:klon,is_sic,k) =   phy_ice(1:klon) 
+     $            - pctsrf_t(1:klon,is_lic,k)
+c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP
+            WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0)
+              pctsrf_t(1:klon,is_sic,k) = 0.
+            END WHERE 
+            WHERE( 1. - zmasq(1:klon) .LT. EPSFRA)
+              pctsrf_t(1:klon,is_sic,k) = 0.
+              pctsrf_t(1:klon,is_oce,k) = 0.
+            END WHERE
+            DO i = 1, klon
+              IF ( 1. - zmasq(i) .GT. EPSFRA) THEN 
+                IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN
+                  pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                  pctsrf_t(i,is_oce,k) = 0.
+                ELSE 
+                  pctsrf_t(i,is_oce,k) = 1 - zmasq(i) 
+     $                    - pctsrf_t(i,is_sic,k)
+                  IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN
+                    pctsrf_t(i,is_oce,k) = 0.
+                    pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                  ENDIF 
+                ENDIF
+              ENDIF  
+              if (pctsrf_t(i,is_oce,k) .lt. 0.) then
+                WRITE(*,*) 'pb sous maille au point : i,k '
+     $              , i,k,pctsrf_t(:,is_oce,k)
+              ENDIF
+              IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + 
+     $          pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k)  - 1.) 
+     $            .GT. EPSFRA) THEN 
+                  WRITE(*,*) 'physiq : pb sous surface au point ', i, 
+     $                pctsrf_t(i, 1 : nbsrf,k), phy_ice(i)
+              ENDIF 
+            END DO
+          ELSE 
+            DO i = 1, klon
+              pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter)
+              IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN
+                pctsrf_t(i,is_sic,k) = 0.
+                pctsrf_t(i,is_oce,k) = 0.                  
+                IF(phy_ice(i) .GE. 1.e-5) THEN
+                  pctsrf_t(i,is_lic,k) = phy_ice(i)
+                  pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) 
+     .                                   - pctsrf_t(i,is_lic,k)
+                ELSE
+                  pctsrf_t(i,is_lic,k) = 0.
+                ENDIF 
+              ELSE
+                pctsrf_t(i,is_lic,k) = 0. 
+                IF(phy_ice(i) .GE. 1.e-5) THEN 
+                  pctsrf_t(i,is_ter,k) = 0.
+                  pctsrf_t(i,is_sic,k) = phy_ice(i)
+                  pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k)
+                ELSE
+                  pctsrf_t(i,is_sic,k) = 0.
+                  pctsrf_t(i,is_oce,k) = 1.                      
+                ENDIF 
+              ENDIF
+              verif = pctsrf_t(i,is_ter,k) +
+     .                pctsrf_t(i,is_oce,k) + 
+     .                pctsrf_t(i,is_sic,k) +
+     .                pctsrf_t(i,is_lic,k)
+              IF ( verif .LT. 1. - 1.e-5 .OR. 
+     $             verif .GT. 1 + 1.e-5) THEN  
+                WRITE(*,*) 'pb sous maille au point : i,k,verif '
+     $                    , i,k,verif
+              ENDIF 
+            END DO
+          ENDIF 
+        ELSE  
+          DO i = 1, klon
+            phy_nat(i,k) = phy_nat0(i)
+            IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN
+              IF (NINT(phy_nat0(i)).EQ.0) THEN
+                phy_nat(i,k) = 3.0
+              ELSE
+                phy_nat(i,k) = 2.0
+              ENDIF
+            ENDIF
+            IF( NINT(phy_nat(i,k)).EQ.0 ) THEN
+              IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001
+            ENDIF
+          END DO
+        ENDIF
+      ENDDO
+c
+
+      ierr = NF_CLOSE(ncid)
+c
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+
+477    continue
+c
+C Traitement de la sst
+c
+      PRINT*, 'Traitement de la sst'
+c     ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid)
+      ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) THEN
+        ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid)
+        if (ierr.ne.0) THEN
+          print *, NF_STRERROR(ierr)
+          STOP
+        endif
+      ENDIF
+
+cIM22/02/2002
+cIM   ierr = NF_INQ_VARID(ncid,'SST',varid)
+      ierr = NF_INQ_VARID(ncid,'tosbcs',varid)
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable SST ', namedim,'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+ 
+      ALLOCATE( dlon_ini(imdep) )
+      ALLOCATE(     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable SST ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlat_ini(jmdep) )
+      ALLOCATE(     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+cIM28/02/2002
+cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
+c               Ici on suppose qu'on a 12 mois (de 30 jours).
+      IF (lmdep.NE.12) THEN
+          print *, 'Unknown AMIP file: not 12 months ?'
+          STOP
+       ENDIF
+cIM28/02/2002
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+       ALLOCATE( champ(imdep*jmdep) )
+       IF( extrap )   THEN
+         ALLOCATE ( work(imdep,jmdep) )
+       ENDIF
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         title='Sst Amip'
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                            dlon, dlat, champ, interbar     )
+       IF ( extrap )  THEN
+        CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work)
+       ENDIF
+c
+
+      IF ( interbar )  THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour la Sst Amip $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+       CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
+     , champ, iim, jjm, rlonu, rlatv, jjp1, champint )
+      ELSE
+       CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .          iim, jjp1, rlonv, rlatu, champint   )
+      ENDIF
+
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+cIM28/02/2002 <==PM  timeyear(l) = timecoord(l)
+         timeyear(l) = tmidmonth(l)
+      ENDDO
+      print 222,  timeyear
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' SST au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+cIM14/03/2002 : SST amipbc greater then 271.38
+      PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 '
+      DO k = 1, 360
+      DO j = 1, jjp1
+      DO i = 1, iim
+         champan(i, j, k) = amax1(champan(i, j, k), 271.38)
+      ENDDO
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+cIM14/03/2002
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon, 
+     .                  champan(1,1,k), phy_sst(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+c
+C Traitement de l'albedo
+c
+      PRINT*, 'Traitement de l albedo'
+      ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlon_ini(imdep) )
+      ALLOCATE (     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlat_ini(jmdep) )
+      ALLOCATE (     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      ALLOCATE ( champ(imdep*jmdep) )
+
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         title='Albedo Amip'
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                            dlon, dlat, champ, interbar      )
+c
+c
+      IF ( interbar )  THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour l Albedo Amip $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+
+       CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
+     , champ, iim, jjm, rlonu, rlatv, jjp1, champint )
+      ELSE
+       CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .          iim, jjp1, rlonv, rlatu, champint   )
+      ENDIF
+c
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i, j, l) = champint(i, j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+      print 222,  timeyear
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i, j, l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Albedo au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_alb(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+c
+      DO k = 1, 360
+      DO i = 1, klon
+         phy_bil(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      PRINT*, 'Ecriture du fichier limit'
+c
+      ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
+     .                       "Fichier conditions aux limites")
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+      ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+c
+      dims(1) = ndim
+      dims(2) = ntim
+c
+      ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
+      ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
+     .                        "Jour dans l annee")
+      IF (newlmt) THEN
+c
+        ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14,
+     .                      "Fraction ocean")
+c
+        ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21,
+     .                      "Fraction glace de mer")
+c
+        ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14,
+     .                      "Fraction terre")
+c
+        ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17,
+     .                      "Fraction land ice")
+c
+      ELSE 
+        ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+        ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
+     .                      "Nature du sol (0,1,2,3)")
+      ENDIF 
+      ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
+      ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
+     .                      "Temperature superficielle de la mer")
+      ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
+      ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
+     .                        "Reference flux de chaleur au sol")
+      ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
+      ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
+     .                        "Albedo a la surface")
+      ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+      ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
+     .                        "Rugosite")
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO k = 1, 360
+c
+      debut(1) = 1
+      debut(2) = k
+      epais(1) = klon
+      epais(2) = 1
+c
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+c
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+c
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+      ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
+#endif
+c
+      ENDDO
+c
+      ierr = NF_CLOSE(nid)
+c
+      STOP
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/limx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/limx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/limx.F	(revision 984)
@@ -0,0 +1,110 @@
+!
+! $Header$
+!
+      SUBROUTINE limx(s0,sx,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+      real sx(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL q(ip1jmp1,llm)
+      real dxq(ip1jmp1,llm)
+
+
+      REAL new_m,zm
+      real dxqu(ip1jmp1)
+      real adxqu(ip1jmp1),dxqmax(ip1jmp1)
+
+      Logical extremum,first
+      save first
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      EXTERNAL filtreg
+
+      data first/.true./
+
+
+       DO  l = 1,llm
+         DO  ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dxq(ij,l) = sx(ij,l) /sm(ij,l)
+         ENDDO
+       ENDDO
+
+c   calcul de la pente a droite et a gauche de la maille
+
+      do l = 1, llm
+         do ij=iip2,ip1jm-1
+            dxqu(ij)=q(ij+1,l)-q(ij,l)
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqu(ij)=dxqu(ij-iim)
+         enddo
+
+         do ij=iip2,ip1jm
+            adxqu(ij)=abs(dxqu(ij))
+         enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+         do ij=iip2+1,ip1jm
+            dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqmax(ij-iim)=dxqmax(ij)
+         enddo
+
+c   calcul de la pente avec limitation
+
+         do ij=iip2+1,ip1jm
+            if(     dxqu(ij-1)*dxqu(ij).gt.0.
+     &         .and. dxq(ij,l)*dxqu(ij).gt.0.) then
+              dxq(ij,l)=
+     &         sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
+            else
+c   extremum local
+               dxq(ij,l)=0.
+            endif
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         enddo
+
+         DO  ij=1,ip1jmp1
+               sx(ij,l) = dxq(ij,l)*sm(ij,l)
+         ENDDO
+
+       ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/limy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/limy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/limy.F	(revision 984)
@@ -0,0 +1,194 @@
+!
+! $Header$
+!
+      SUBROUTINE limy(s0,sy,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL q(ip1jmp1,llm)
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      real sigv,dyq(ip1jmp1),dyqv(ip1jm)
+      real adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2
+      Logical extremum,first
+      save first
+
+      real convpn,convps,convmpn,convmps
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      save sinlon,coslon,sinlondlon,coslondlon
+c
+c
+      REAL      SSUM
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      EXTERNAL filtreg
+
+      data first/.true./
+
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+      endif
+
+c
+
+      do l = 1, llm
+c
+         DO ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dyq(ij) = sy(ij,l) / sm ( ij,l )
+         ENDDO
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      airej2 = SSUM( iim, aire(iip2), 1 )
+      airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      do ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      do ij=iip2,ip1jm
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      enddo
+
+c   calcul des pentes aux poles
+
+c   calcul des pentes limites aux poles
+
+c     print*,dyqv(iip1+1)
+c     apn=abs(dyq(1)/dyqv(iip1+1))
+c     print*,dyq(ip1jm+1)
+c     print*,dyqv(ip1jm-iip1+1)
+c     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+c     do ij=2,iim
+c        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+c        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+c     enddo
+c     apn=min(pente_max/apn,1.)
+c     aps=min(pente_max/aps,1.)
+
+
+c   cas ou on a un extremum au pole
+
+c     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+c    &   apn=0.
+c     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+c    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+c    &   aps=0.
+
+c   limitation des pentes aux poles
+c     do ij=1,iip1
+c        dyq(ij)=apn*dyq(ij)
+c        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+c     enddo
+
+c   test
+c      do ij=1,iip1
+c         dyq(iip1+ij)=0.
+c         dyq(ip1jm+ij-iip1)=0.
+c      enddo
+c      do ij=1,ip1jmp1
+c         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+c      enddo
+
+      if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+     &   then
+         do ij=1,iip1
+            dyqmax(ij)=0.
+         enddo
+      else
+         do ij=1,iip1
+            dyqmax(ij)=pente_max*abs(dyqv(ij))
+         enddo
+      endif
+
+      if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+     & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+     &then
+         do ij=ip1jm+1,ip1jmp1
+            dyqmax(ij)=0.
+         enddo
+      else
+         do ij=ip1jm+1,ip1jmp1
+            dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+         enddo
+      endif
+
+c   calcul des pentes limitees
+
+      do ij=1,ip1jmp1
+         if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then
+            dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))
+         else
+            dyq(ij)=0.
+         endif
+      enddo
+
+         DO ij=1,ip1jmp1
+               sy(ij,l) = dyq(ij) * sm ( ij,l )
+        ENDDO
+
+      enddo ! fin de la boucle sur les couches verticales
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/limz.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/limz.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/limz.F	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE limz(s0,sz,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+      real sz(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL q(ip1jmp1,llm)
+      real dzq(ip1jmp1,llm)
+
+
+      REAL new_m,zm
+      real dzqw(ip1jmp1)
+      real adzqw(ip1jmp1),dzqmax(ip1jmp1)
+
+      Logical extremum,first
+      save first
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      EXTERNAL filtreg
+
+      data first/.true./
+
+
+       DO  l = 1,llm
+         DO  ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dzq(ij,l) = sz(ij,l) /sm(ij,l)
+         ENDDO
+       ENDDO
+
+c   calcul de la pente en haut et en bas de la maille
+       do ij=1,ip1jmp1
+       do l = 1, llm-1
+            dzqw(l)=q(ij,l+1)-q(ij,l)
+         enddo
+            dzqw(llm)=0.
+
+         do  l=1,llm
+            adzqw(l)=abs(dzqw(l))
+         enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+         do l=2,llm-1
+            dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l))
+         enddo
+
+c   calcul de la pente avec limitation
+
+         do l=2,llm-1
+            if(     dzqw(l-1)*dzqw(l).gt.0.
+     &         .and. dzq(ij,l)*dzqw(l).gt.0.) then
+              dzq(ij,l)=
+     &         sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l))
+            else
+c   extremum local
+               dzq(ij,l)=0.
+            endif
+         enddo
+
+         DO  l=1,llm
+               sz(ij,l) = dzq(ij,l)*sm(ij,l)
+         ENDDO
+
+       ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/logic.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/logic.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/logic.h	(revision 984)
@@ -0,0 +1,18 @@
+!
+! $Header$
+!
+c
+c
+c-----------------------------------------------------------------------
+c INCLUDE 'logic.h'
+
+      COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys,
+     .  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus
+     .  ,read_start,ok_guide
+
+      LOGICAL purmats,forward,leapf,apphys,statcl,conser,
+     . apdiss,apdelq,saison,ecripar,fxyhypb,ysinus
+     .  ,read_start,ok_guide
+
+      INTEGER iflag_phys
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/massbar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/massbar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/massbar.F	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE massbar(  masse, massebx, masseby )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO  ij = 1, ip1jmp1 - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jmp1, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+         DO  ij = 1,ip1jm
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/massbarxy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/massbarxy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/massbarxy.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE massbarxy(  masse, massebxy )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = 1, ip1jm - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/massdair.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/massdair.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/massdair.F	(revision 984)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE massdair( p, masse )
+c
+c *********************************************************************
+c       ....  Calcule la masse d'air  dans chaque maille   ....
+c *********************************************************************
+c
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..    p                      est  un argum. d'entree pour le s-pg ...
+c  ..  masse                    est un  argum.de sortie pour le s-pg ...
+c     
+c  ....  p est defini aux interfaces des llm couches   .....
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c  .....   arguments  ....
+c
+      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
+
+c   ....  Variables locales  .....
+
+      INTEGER l,ij
+      REAL massemoyn, massemoys
+
+      REAL SSUM
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO    ij     = 1, ip1jmp1
+         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+        ENDDO
+c
+        DO   ij = 1, ip1jmp1,iip1
+         masse(ij+ iim,l) = masse(ij,l)
+        ENDDO
+c
+c       DO    ij     = 1,  iim
+c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
+c       ENDDO
+c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+c       DO    ij     = 1, iip1
+c        masse(   ij   ,l )    = massemoyn
+c        masse(ij+ip1jm,l )    = massemoys
+c       ENDDO
+       
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/minmax.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/minmax.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/minmax.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/minmax2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/minmax2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/minmax2.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/mod_const_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/mod_const_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/mod_const_para.F90	(revision 984)
@@ -0,0 +1,16 @@
+MODULE mod_const_mpi
+
+  INTEGER :: COMM_LMDZ
+  INTEGER :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+  IMPLICIT NONE
+  
+    COMM_LMDZ=0
+    MPI_REAL_LMDZ=0
+  END SUBROUTINE Init_const_mpi
+
+END MODULE mod_const_mpi
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrad.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrad.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrad.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrad (klevel, rot, x, y )
+c
+c     P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrad_gam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrad_gam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrad_gam.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrad_gam( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/nxgradst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/nxgradst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/nxgradst.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgradst (klevel,rot, x, y )
+c
+      IMPLICIT NONE
+c     Auteur :  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y(ij,l)=( rot(ij,l) - rot(ij-1,l))
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/nxgraro2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/nxgraro2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/nxgraro2.F	(revision 984)
@@ -0,0 +1,68 @@
+!
+! $Header$
+!
+       SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
+c
+c      P.Le Van .
+c   ***********************************************************
+c                                 lr
+c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+c
+c    ......  variables en arguments  .......
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL rot(ip1jm,llm) , signe, nugradrs
+      INTEGER l,ij,iter,lr
+c    ........................................................
+c
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+c
+      CALL     rotatf     ( klevel, grx, gry, rot )
+c
+      CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
+
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+        CALL laplacien_rotgam ( klevel, rot, rot )
+      ENDDO
+c
+c
+      CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
+      CALL nxgrad ( klevel, rot, grx, gry )
+c
+      DO    l = 1, klevel
+         DO  ij = 1, ip1jm
+          gry( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+         DO  ij = 1, ip1jmp1
+          grx( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrarot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrarot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/nxgrarot.F	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
+c   ***********************************************************
+c
+c    Auteur :  P.Le Van  
+c
+c                                 lr
+c      calcul de  ( nXgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+      REAL rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      DO 10 iter = 1,lr
+      CALL  rotat (klevel,grx, gry, rot )
+      CALL filtreg( rot, jjm, klevel, 2,1, .false.,2)
+      CALL nxgrad (klevel,rot, grx, gry )
+c
+      DO 5  l = 1, klevel
+      DO 2 ij = 1, ip1jm
+      gry( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      DO 3 ij = 1, ip1jmp1
+      grx( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ord_coord.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ord_coord.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ord_coord.F	(revision 984)
@@ -0,0 +1,95 @@
+!
+! $Header$
+!
+       SUBROUTINE ord_coord ( nmax, xi, xo, decrois )
+
+c   .... Auteur :  P. Le Van  .... 
+c
+c   ... Reordonne eventuellement les coordonnees de la grille donnees ...
+c
+       IMPLICIT NONE
+
+c    .....  Arguments  en entree  .....
+
+       INTEGER nmax
+       REAL xi(nmax)
+
+c    .....  Arguments  en sortie  .....
+c
+       REAL xo(nmax+1) 
+       LOGICAL decrois
+
+c    .... Variables  locales  ....
+
+       REAL xscr(nmax)
+       INTEGER i,ii
+       REAL pi, degres, chmin, chmax, mult
+c
+
+       pi     = 2.*ASIN(1.)
+       degres = 180./pi
+       decrois = .FALSE.
+
+       DO i = 1, nmax 
+        xo(i) = xi(i)
+       ENDDO
+     
+       mult = 1.
+       IF( xo(1).GT.xo(nmax) ) mult = -1.
+
+       CALL minmax(nmax,xo(1),chmin,chmax)
+
+       IF(chmax.LT.6.5 )  THEN
+          DO i = 1,nmax
+           xo(i) = xo(i) * degres 
+          ENDDO
+       ENDIF
+
+       IF( ABS( xo( 1  ) + mult* 90. ). LT .0.001. OR .
+     ,     ABS( xo(nmax) - mult* 90. ). LT .0.001      )  THEN
+        PRINT *,' Reverifier les valeurs de  xidat  pour les donnees .'
+        PRINT *,' Elles doivent correspondre aux interfaces et non aux',
+     , 'ordonnees des donnees,egales a -90. et 90.deg aux 2 extremites '
+         CALL ABORT
+       ENDIF
+
+       IF( xo(1).GT.xo(nmax) )   THEN
+          DO i = 1, nmax 
+            xscr(i) = xo(i)
+          ENDDO
+          DO i = 1, nmax 
+            xo(i+1) = xscr(i)
+          ENDDO
+            xo (   1    ) =   90.
+       ELSE
+            xo ( nmax +1) =   90.
+       ENDIF
+
+       IF ( xo(2).LT.xo(1) ) decrois =.TRUE.
+
+       DO i = 3, nmax 
+
+        IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN
+         PRINT 1
+         PRINT 2,(xo(ii),ii=1,nmax)
+         CALL ABORT 
+        ENDIF
+        IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN
+         PRINT 1
+         PRINT 2,(xo(ii),ii=1,nmax)
+         CALL ABORT
+        ENDIF
+
+       ENDDO
+        
+       IF( decrois )  THEN
+c         CALL sort(nmax+1,xo(1))
+        CALL sort(nmax+1,xo)
+       ENDIF
+
+1      FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ',
+     ,  'grille du modele ')
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ord_coordm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ord_coordm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ord_coordm.F	(revision 984)
@@ -0,0 +1,110 @@
+!
+! $Header$
+!
+       SUBROUTINE ord_coordm ( nmax, xi, xo, jjm, jmods, decrois )
+
+c   ....  Auteur :  P. Le Van  .... 
+
+c   ... Reordonne eventuellement les coordonnees de la grille modele ...
+c
+       IMPLICIT NONE
+
+c    .....  Arguments  en entree  .....
+
+       INTEGER nmax,jjm
+       REAL xi(nmax)
+
+c    .....  Arguments  en sortie  .....
+c
+       REAL xo(nmax+1) 
+       LOGICAL decrois
+       INTEGER jmods
+
+c    .... Variables  locales  ....
+
+       REAL xscr(nmax)
+       INTEGER i
+       REAL pi, degres, chmin, chmax,mult
+c
+       DO i = 1, nmax 
+        xo(i) = xi(i)
+       ENDDO
+
+       mult = 1.
+       IF( xo(1).GT.xo(nmax) )  mult = - 1.
+       IF( nmax.EQ.jjm    ) jmods = nmax +1
+       IF( nmax.EQ.jjm +1 ) jmods = nmax -1 
+     
+       pi     = 2.*ASIN(1.)
+       degres = 180./pi
+       decrois = .FALSE.
+
+       CALL minmax(nmax,xo(1),chmin,chmax)
+
+       IF(chmax.LT.6.5 )  THEN
+          DO i = 1,nmax
+           xo(i) = xo(i) * degres 
+          ENDDO
+       ENDIF
+
+       IF( nmax.EQ.jjm )   THEN
+         IF( xo(1).GT.xo(nmax) )   THEN
+           DO i = 1, nmax 
+            xscr(i) = xo(i)
+           ENDDO
+           DO i = 1, nmax 
+            xo(i+1) = xscr(i)
+           ENDDO
+            xo (   1    ) =   90.
+         ELSE
+            xo ( nmax+1 ) =   90.
+         ENDIF
+       ELSE
+          IF( nmax.NE.jjm +1 )   THEN
+             PRINT *,'  Dans la routine ord_coordm , l argument nmax '
+             PRINT *,'  n est pas egal a jjm ni a jjm +1 . Corriger !'
+             CALL ABORT
+          ELSE
+            IF( ABS( xo(1)+ mult * 90.).GT.0.01 )  THEN
+              PRINT *,' Avec nmax =',nmax,'on devrait avoir des',
+     ,    ' ordonnees = 90. deg pour j=1 ou jjm+1 ! '
+             CALL ABORT
+            ELSE
+               IF( xo(1).LT.xo(nmax) )  THEN
+                 DO i = 1, nmax
+                  xscr(i) = xo(i)
+                 ENDDO
+                 DO i = 1, nmax -1
+                  xo(i) = xscr(i+1)
+                 ENDDO
+               ENDIF
+            ENDIF
+          ENDIF
+       ENDIF
+
+       IF ( xo(2).LT.xo(1) ) decrois =.TRUE.
+
+       DO i = 3, nmax 
+
+        IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN
+         PRINT 1
+         CALL ABORT 
+        ENDIF
+        IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN
+         PRINT 1
+         CALL ABORT
+        ENDIF
+
+       ENDDO
+        
+       IF( decrois )  THEN
+         CALL sort(jmods,xo(1))
+       ENDIF
+
+
+1      FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ',
+     ,  'grille du modele ')
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/paramet.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/paramet.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/paramet.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3                &
+     &    ,jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/pbar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/pbar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/pbar.F	(revision 984)
@@ -0,0 +1,124 @@
+!
+! $Header$
+!
+      SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c *********************************************************************
+c
+c          pext               est  un argum. d'entree  pour le s-pg ..
+c     pbarx,pbary et pbarxy  sont des argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+
+#include "comgeom.h"
+
+      REAL pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
+      REAL pbary(  ip1jm  ),  pbarxy(  ip1jm  )
+
+      INTEGER   ij
+
+
+
+      DO 1 ij = 1, ip1jmp1 - 1
+      pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
+   1  CONTINUE
+
+c    .... correction pour pbarx( iip1,j) .....
+
+c    ...    pbarx(iip1,j)= pbarx(1,j) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jmp1, iip1
+      pbarx( ij ) = pbarx( ij - iim )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     +
+     *              pext( ij+iip1 ) * alpha1p4( ij+iip1 )
+   3  CONTINUE
+
+
+      DO 5 ij = 1, ip1jm - 1
+      pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     pbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      pbarxy( ij ) = pbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/pentes_ini.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/pentes_ini.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/pentes_ini.F	(revision 984)
@@ -0,0 +1,478 @@
+!
+! $Header$
+!
+      SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
+      IMPLICIT NONE
+
+c=======================================================================
+c   Adaptation LMDZ:  A.Armengaud (LGGE)
+c   ----------------
+c
+c   ********************************************************************
+c   Transport des traceurs par la methode des pentes
+c   ********************************************************************
+c   Reference possible : Russel. G.L., Lerner J.A.:
+c         A new Finite-Differencing Scheme for Traceur Transport 
+c         Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 
+c   ********************************************************************
+c   q,w,masse,pbaru et pbarv 
+c                      sont des arguments d'entree  pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c   Arguments:
+c   ----------
+      integer mode
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL q( iip1,jjp1,llm,0:3)
+      REAL w( ip1jmp1,llm )
+      REAL masse( iip1,jjp1,llm)
+c   Local:
+c   ------
+      LOGICAL limit
+      REAL sm ( iip1,jjp1, llm )
+      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+      real masn,mass,zz
+      INTEGER i,j,l,iq
+
+c  modif Fred 24 03 96
+
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      save sinlon,coslon,sinlondlon,coslondlon
+      real dyn1,dyn2,dys1,dys2
+      real qpn,qps,dqzpn,dqzps
+      real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1)
+      real qmin,zq,pente_max
+c
+      REAL      SSUM
+      integer ismax,ismin,lati,latf
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      logical first
+      save first
+c   fin modif
+
+c      EXTERNAL masskg
+      EXTERNAL advx
+      EXTERNAL advy
+      EXTERNAL advz
+
+c  modif Fred 24 03 96
+      data first/.true./
+
+      limit = .TRUE.
+      pente_max=2
+c     if (mode.eq.1.or.mode.eq.3) then
+c     if (mode.eq.1) then
+      if (mode.ge.1) then
+        lati=2
+        latf=jjm
+      else
+        lati=1
+        latf=jjp1
+      endif
+
+      qmin=0.4995
+      qmin=0.
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+            print*,coslondlon(i),sinlondlon(i)
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1)
+         print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1)
+        DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+         q ( i,j,l,1 )=0.
+         q ( i,j,l,2 )=0.
+         q ( i,j,l,3 )=0.  
+         ENDDO
+         ENDDO
+        ENDDO
+        
+      endif
+c   Fin modif Fred
+
+c *** q contient les qqtes de traceur avant l'advection 
+
+c *** Affectation des tableaux S a partir de Q
+c *** Rem : utilisation de SCOPY ulterieurement
+ 
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+             s0( i,j,llm+1-l ) = q ( i,j,l,0 )
+             sx( i,j,llm+1-l ) = q ( i,j,l,1 )
+             sy( i,j,llm+1-l ) = q ( i,j,l,2 )
+             sz( i,j,llm+1-l ) = q ( i,j,l,3 )
+         ENDDO
+        ENDDO
+       ENDDO
+
+c      PRINT*,'----- S0 just before conversion -------'
+c      PRINT*,'S0(16,12,1)=',s0(16,12,1) 
+c      PRINT*,'Q(16,12,1,4)=',q(16,12,1,4)
+
+c *** On calcule la masse d'air en kg
+
+       DO  l = 1,llm
+         DO  j = 1,jjp1
+           DO  i = 1,iip1
+            sm ( i,j,llm+1-l)=masse( i,j,l )
+          ENDDO
+         ENDDO
+       ENDDO
+
+c *** On converti les champs S en atome (resp. kg) 
+c *** Les routines d'advection traitent les champs
+c *** a advecter si ces derniers sont en atome (resp. kg)
+c *** A optimiser !!!
+
+       DO  l = 1,llm
+         DO  j = 1,jjp1
+           DO  i = 1,iip1
+               s0(i,j,l) = s0(i,j,l) * sm ( i,j,l )
+               sx(i,j,l) = sx(i,j,l) * sm ( i,j,l )
+               sy(i,j,l) = sy(i,j,l) * sm ( i,j,l )
+               sz(i,j,l) = sz(i,j,l) * sm ( i,j,l )
+           ENDDO
+         ENDDO
+       ENDDO
+
+c       ss0 = 0.
+c       DO l = 1,llm
+c        DO j = 1,jjp1
+c         DO i = 1,iim
+c            ss0 = ss0 + s0 ( i,j,l )
+c         ENDDO
+c        ENDDO
+c       ENDDO
+c       PRINT*, 'valeur tot s0 avant advection=',ss0
+
+c *** Appel des subroutines d'advection en X, en Y et en Z
+c *** Advection avec "time-splitting"
+      
+c-----------------------------------------------------------
+c      PRINT*,'----- S0 just before ADVX -------'
+c      PRINT*,'S0(16,12,1)=',s0(16,12,1)
+
+c-----------------------------------------------------------
+c      do l=1,llm
+c         do j=1,jjp1
+c          do i=1,iip1
+c             zq=s0(i,j,l)/sm(i,j,l)
+c            if(zq.lt.qmin)
+c    ,       print*,'avant advx1, s0(',i,',',j,',',l,')=',zq
+c          enddo
+c         enddo
+c      enddo
+CCC
+       if(mode.eq.2) then
+          do l=1,llm
+            s0s=0.
+            s0n=0.
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            smn=0.
+            sms=0.
+            do i=1,iim
+               smn=smn+sm(i,1,l)
+               sms=sms+sm(i,jjp1,l)
+               s0n=s0n+s0(i,1,l)
+               s0s=s0s+s0(i,jjp1,l)
+               zz=sy(i,1,l)/sm(i,1,l)
+               dyn1=dyn1+sinlondlon(i)*zz
+               dyn2=dyn2+coslondlon(i)*zz
+               zz=sy(i,jjp1,l)/sm(i,jjp1,l)
+               dys1=dys1+sinlondlon(i)*zz
+               dys2=dys2+coslondlon(i)*zz
+            enddo
+            do i=1,iim
+               sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i)
+               sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i)
+            enddo
+            do i=1,iim
+               s0(i,1,l)=s0n/smn+sy(i,1,l)
+               s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l)
+            enddo
+
+            s0(iip1,1,l)=s0(1,1,l)
+            s0(iip1,jjp1,l)=s0(1,jjp1,l)
+
+            do i=1,iim
+               sxn(i)=s0(i+1,1,l)-s0(i,1,l)
+               sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l)
+c   on rerentre les masses
+            enddo
+            do i=1,iim
+               sy(i,1,l)=sy(i,1,l)*sm(i,1,l)
+               sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l)
+               s0(i,1,l)=s0(i,1,l)*sm(i,1,l)
+               s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l)
+            enddo
+            sxn(iip1)=sxn(1)
+            sxs(iip1)=sxs(1)
+            do i=1,iim
+               sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l)
+               sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l)
+            enddo
+            s0(iip1,1,l)=s0(1,1,l)
+            s0(iip1,jjp1,l)=s0(1,jjp1,l)
+            sy(iip1,1,l)=sy(1,1,l)
+            sy(iip1,jjp1,l)=sy(1,jjp1,l)
+            sx(1,1,l)=sx(iip1,1,l)
+            sx(1,jjp1,l)=sx(iip1,jjp1,l)
+          enddo
+      endif
+
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+      call limx(s0,sx,sm,pente_max)
+c     call minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+       call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
+c     call minmaxq(zq,1.e33,-1.e33,'avant advy     ')
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+       call   limy(s0,sy,sm,pente_max)
+       call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) 
+c     call minmaxq(zq,1.e33,-1.e33,'avant advz     ')
+       do j=1,jjp1
+          do i=1,iip1
+             sz(i,j,1)=0.
+             sz(i,j,llm)=0.
+          enddo
+       enddo
+       call limz(s0,sz,sm,pente_max)
+       call advz( limit,dtvr,w,sm,s0,sx,sy,sz )
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+        call limy(s0,sy,sm,pente_max)
+       call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) 
+       do l=1,llm
+          do j=1,jjp1
+             sm(iip1,j,l)=sm(1,j,l)
+             s0(iip1,j,l)=s0(1,j,l)
+             sx(iip1,j,l)=sx(1,j,l)
+             sy(iip1,j,l)=sy(1,j,l)
+             sz(iip1,j,l)=sz(1,j,l)
+          enddo
+       enddo
+
+
+c     call minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+       call limx(s0,sx,sm,pente_max)
+       call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) 
+c     call minmaxq(zq,1.e33,-1.e33,'apres advx     ')
+c      do l=1,llm
+c         do j=1,jjp1
+c          do i=1,iip1
+c             zq=s0(i,j,l)/sm(i,j,l)
+c            if(zq.lt.qmin)
+c    ,       print*,'apres advx2, s0(',i,',',j,',',l,')=',zq
+c          enddo
+c         enddo
+c      enddo
+c ***   On repasse les S dans la variable q directement 14/10/94
+c   On revient a des rapports de melange en divisant par la masse
+
+c En dehors des poles:
+
+       DO  l = 1,llm
+        DO  j = 1,jjp1
+         DO  i = 1,iim
+             q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l)
+         ENDDO
+        ENDDO
+      ENDDO
+
+c Traitements specifiques au pole
+
+      if(mode.ge.1) then
+      DO l=1,llm
+c   filtrages aux poles
+         masn=ssum(iim,sm(1,1,l),1)
+         mass=ssum(iim,sm(1,jjp1,l),1)
+         qpn=ssum(iim,s0(1,1,l),1)/masn
+         qps=ssum(iim,s0(1,jjp1,l),1)/mass
+         dqzpn=ssum(iim,sz(1,1,l),1)/masn
+         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+         do i=1,iip1
+            q( i,1,llm+1-l,3)=dqzpn
+            q( i,jjp1,llm+1-l,3)=dqzps
+            q( i,1,llm+1-l,0)=qpn
+            q( i,jjp1,llm+1-l,0)=qps
+         enddo
+         if(mode.eq.3) then
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            do i=1,iim
+               dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l)
+               dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l)
+               dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+               dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+            enddo
+            do i=1,iim
+               q(i,1,llm+1-l,2)=
+     s          (sinlon(i)*dyn1+coslon(i)*dyn2)
+               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+               q(i,jjp1,llm+1-l,2)=
+     s          (sinlon(i)*dys1+coslon(i)*dys2)
+               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     s         -q(i,jjp1,llm+1-l,2)
+            enddo
+         endif
+         if(mode.eq.1) then
+c   on filtre les valeurs au bord de la "grande maille pole"
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            do i=1,iim
+               zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+               dyn1=dyn1+sinlondlon(i)*zz
+               dyn2=dyn2+coslondlon(i)*zz
+               zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+               dys1=dys1+sinlondlon(i)*zz
+               dys2=dys2+coslondlon(i)*zz
+            enddo
+            do i=1,iim
+               q(i,1,llm+1-l,2)=
+     s          (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+               q(i,jjp1,llm+1-l,2)=
+     s          (sinlon(i)*dys1+coslon(i)*dys2)/2.
+               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     s         -q(i,jjp1,llm+1-l,2)
+            enddo
+            q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+            q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+
+            do i=1,iim
+               sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+               sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+            enddo
+            sxn(iip1)=sxn(1)
+            sxs(iip1)=sxs(1)
+            do i=1,iim
+               q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+               q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+            enddo
+            q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+            q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1)
+
+         endif
+
+       ENDDO
+       endif
+
+c bouclage en longitude
+      do iq=0,3
+         do l=1,llm
+            do j=1,jjp1
+               q(iip1,j,l,iq)=q(1,j,l,iq)
+            enddo
+         enddo
+      enddo
+
+c       PRINT*, ' SORTIE DE PENTES ---  ca peut glisser ....'
+
+        DO l = 1,llm
+    	 DO j = 1,jjp1
+    	  DO i = 1,iip1
+                IF (q(i,j,l,0).lt.0.)  THEN
+c                    PRINT*,'------------ BIP-----------' 
+c                    PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0)
+c                    PRINT*,'QX(',i,j,l,')=',q(i,j,l,1)
+c                    PRINT*,'QY(',i,j,l,')=',q(i,j,l,2)
+c                    PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3)
+c       		     PRINT*,' PBL EN SORTIE DE PENTES'
+                     q(i,j,l,0)=0.
+c                    STOP
+                 ENDIF
+          ENDDO
+         ENDDO
+        ENDDO
+
+c       PRINT*, '-------------------------------------------'
+        
+       do l=1,llm
+          do j=1,jjp1
+           do i=1,iip1
+             if(q(i,j,l,0).lt.qmin)
+     ,       print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)
+           enddo
+          enddo
+       enddo
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ppm3d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ppm3d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ppm3d.F	(revision 984)
@@ -0,0 +1,2001 @@
+!
+! $Header$
+!
+
+cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998
+cDate: Wed, 15 Apr 1998 11:37:03 -0400
+cFrom: lin@explorer.gsfc.nasa.gov
+cTo: Frederic.Hourdin@lmd.jussieu.fr
+cSubject: 3D transport module of the GSFC CTM and GEOS GCM
+
+
+cThis code is sent to you by S-J Lin, DAO, NASA-GSFC
+
+cNote: this version is intended for machines like CRAY
+C-90. No multitasking directives implemented.
+
+      
+C ********************************************************************
+C
+C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard
+C Earth Observing System General Circulation Model (GEOS-GCM), and Data
+C Assimilation System (GEOS-DAS).
+C
+C ********************************************************************
+C
+C Purpose: given horizontal winds on  a hybrid sigma-p surfaces,
+C          one call to tpcore updates the 3-D mixing ratio
+C          fields one time step (NDT). [vertical mass flux is computed
+C          internally consistent with the discretized hydrostatic mass
+C          continuity equation of the C-Grid GEOS-GCM (for IGD=1)].
+C
+C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based
+C          on the van Leer or PPM.
+C          (see Lin and Rood 1996).
+C Version 4.5
+C Last modified: Dec. 5, 1996
+C Major changes from version 4.0: a more general vertical hybrid sigma-
+C pressure coordinate.
+C Subroutines modified: xtp, ytp, fzppm, qckxyz
+C Subroutines deleted: vanz
+C
+C Author: Shian-Jiann Lin
+C mail address:
+C                 Shian-Jiann Lin*
+C                 Code 910.3, NASA/GSFC, Greenbelt, MD 20771
+C                 Phone: 301-286-9540
+C                 E-mail: lin@dao.gsfc.nasa.gov
+C
+C *affiliation:
+C                 Joint Center for Earth Systems Technology
+C                 The University of Maryland Baltimore County
+C                 NASA - Goddard Space Flight Center
+C References:
+C
+C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi-
+C    Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070.
+C
+C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of
+C    the van Leer-type transport schemes and its applications to the moist-
+C    ure transport in a General Circulation Model. Mon. Wea. Rev., 122,
+C    1575-1593.
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR,
+     &                  JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax)
+
+c      implicit none
+
+c     rajout de déclarations
+c      integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd
+c      integer iu,iiu,j2,jmr,js0,jt
+c      real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp
+c      real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru
+C
+C ********************************************************************
+C
+C =============
+C INPUT:
+C =============
+C
+C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t)
+C NC: total # of constituents
+C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR
+C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1
+C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at
+C       the model top to NLAY near the surface (see fig. below).
+C       It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation)
+C
+C PS1(IMR,JNP): surface pressure at current time (t)
+C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2)
+C PS2 is replaced by the predicted PS (at t+NDT) on output.
+C Note: surface pressure can have any unit or can be multiplied by any
+C       const.
+C
+C The pressure at layer edges are defined as follows:
+C
+C        p(i,j,k) = AP(k)*PT  +  BP(k)*PS(i,j)          (1)
+C
+C Where PT is a constant having the same unit as PS.
+C AP and BP are unitless constants given at layer edges
+C defining the vertical coordinate. 
+C BP(1) = 0., BP(NLAY+1) = 1.
+C The pressure at the model top is PTOP = AP(1)*PT
+C
+C For pure sigma system set AP(k) = 1 for all k, PT = PTOP,
+C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP.
+C
+C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn
+C is a subset of the following even more general sigma-P-thelta coord.
+C currently under development.
+C  p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa))
+C
+C                  /////////////////////////////////
+C              / \ ------------- PTOP --------------  AP(1), BP(1)
+C               |
+C    delp(1)    |  ........... Q(i,j,1) ............  
+C               |
+C      W(1)    \ / ---------------------------------  AP(2), BP(2)
+C
+C
+C
+C     W(k-1)   / \ ---------------------------------  AP(k), BP(k)
+C               |
+C    delp(K)    |  ........... Q(i,j,k) ............ 
+C               |
+C      W(k)    \ / ---------------------------------  AP(k+1), BP(k+1)
+C
+C
+C
+C              / \ ---------------------------------  AP(NLAY), BP(NLAY)
+C               |
+C  delp(NLAY)   |  ........... Q(i,j,NLAY) .........  
+C               |
+C   W(NLAY)=0  \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1)
+C                 //////////////////////////////////
+C
+C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2)
+C U and V may need to be polar filtered in advance in some cases.
+C 
+C IGD:      grid type on which winds are defined.
+C IGD = 0:  A-Grid  [all variables defined at the same point from south
+C                   pole (j=1) to north pole (j=JNP) ]
+C
+C IGD = 1  GEOS-GCM C-Grid
+C                                      [North]
+C
+C                                       V(i,j)
+C                                          |
+C                                          |
+C                                          |
+C                             U(i-1,j)---Q(i,j)---U(i,j) [EAST]
+C                                          |
+C                                          |
+C                                          |
+C                                       V(i,j-1)
+C
+C         U(i,  1) is defined at South Pole.
+C         V(i,  1) is half grid north of the South Pole.
+C         V(i,JMR) is half grid south of the North Pole.
+C
+C         V must be defined at j=1 and j=JMR if IGD=1
+C         V at JNP need not be given.
+C
+C NDT: time step in seconds (need not be constant during the course of
+C      the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5
+C      (Lat-Lon) resolution. Smaller values are recommanded if the model
+C      has a well-resolved stratosphere.
+C
+C J1 defines the size of the polar cap:
+C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg.
+C North polar cap edge is located at  90 - (j1-1.5)*180/(JNP-1) deg.
+C There are currently only two choices (j1=2 or 3).
+C IMR must be an even integer if j1 = 2. Recommended value: J1=3.
+C
+C IORD, JORD, and KORD are integers controlling various options in E-W, N-S,
+C and vertical transport, respectively. Recommended values for positive
+C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non-
+C positive definite scalars or when linear correlation between constituents
+C is to be maintained.
+C
+C  _ORD= 
+C        1: 1st order upstream scheme (too diffusive, not a useful option; it
+C           can be used for debugging purposes; this is THE only known "linear"
+C           monotonic advection scheme.).
+C        2: 2nd order van Leer (full monotonicity constraint;
+C           see Lin et al 1994, MWR)
+C        3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984)
+C        4: semi-monotonic PPM (same as 3, but overshoots are allowed)
+C        5: positive-definite PPM (constraint on the subgrid distribution is
+C           only strong enough to prevent generation of negative values;
+C           both overshoots & undershoots are possible).
+C        6: un-constrained PPM (nearly diffusion free; slightly faster but
+C           positivity not quaranteed. Use this option only when the fields
+C           and winds are very smooth).
+C
+C *PPM: Piece-wise Parabolic Method
+C
+C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5.
+C for non-positive definite scalars (such as Ertel Potential Vorticity).
+C
+C The implicit numerical diffusion decreases as _ORD increases.
+C The last two options (ORDER=5, 6) should only be used when there is
+C significant explicit diffusion (such as a turbulence parameterization). You
+C might get dispersive results otherwise.
+C No filter of any kind is applied to the constituent fields here.
+C
+C AE: Radius of the sphere (meters).
+C     Recommended value for the planet earth: 6.371E6
+C
+C fill(logical):   flag to do filling for negatives (see note below).
+C
+C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s).
+C (220 m/s is a good value for troposphere model; 280 m/s otherwise)
+C
+C =============
+C Output
+C =============
+C
+C Q: mixing ratios at future time (t+NDT) (original values are over-written)
+C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic
+C          relationship. W will have the same unit as PS1 and PS2 (eg, mb).
+C          W must be divided by NDT to get the correct mass-flux unit.
+C          The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND
+C          is the pressure thickness in the "upwind" direction. For example,
+C          C(k) = W(k)/delp(k)   if W(k) > 0;
+C          C(k) = W(k)/delp(k+1) if W(k) < 0.
+C              ( W > 0 is downward, ie, toward surface)
+C PS2: predicted PS at t+NDT (original values are over-written)
+C
+C ********************************************************************
+C NOTES:
+C This forward-in-time upstream-biased transport scheme reduces to
+C the 2nd order center-in-time center-in-space mass continuity eqn.
+C if Q = 1 (constant fields will remain constant). This also ensures
+C that the computed vertical velocity to be identical to GEOS-1 GCM
+C for on-line transport.
+C
+C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when
+C winds are noisy near poles).
+C
+C Flux-Form Semi-Lagrangian transport in the East-West direction is used
+C when and where Courant # is greater than one.
+C
+C The user needs to change the parameter Jmax or Kmax if the resolution
+C is greater than 0.5 deg in N-S or 150 layers in the vertical direction.
+C (this TransPort Core is otherwise resolution independent and can be used
+C as a library routine).
+C
+C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd
+C order accurate for non-uniform grid (vertical sigma coord.).
+C
+C Time step is limitted only by transport in the meridional direction.
+C (the FFSL scheme is not implemented in the meridional direction).
+C
+C Since only 1-D limiters are applied, negative values could
+C potentially be generated when large time step is used and when the
+C initial fields contain discontinuities.
+C This does not necessarily imply the integration is unstable.
+C These negatives are typically very small. A filling algorithm is
+C activated if the user set "fill" to be true.
+C
+C The van Leer scheme used here is nearly as accurate as the original PPM
+C due to the use of a 4th order accurate reference slope. The PPM imple-
+C mented here is an improvement over the original and is also based on
+C the 4th order reference slope.
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C     User modifiable parameters
+C
+      parameter (Jmax = 361, kmax = 150)
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C Input-Output arrays
+C
+      
+      real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP),
+     &     U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1),
+     &     BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax
+      integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE
+      integer IMRD2
+      real    PT       
+      logical  cross, fill, dum
+C
+C Local dynamic arrays
+C
+      real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP),
+     &     fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY),
+     &     WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP),
+     &     delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP),
+     &     UA(IMR,JNP),qtmp(-IMR:2*IMR)
+C
+C Local static  arrays
+C
+      real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax),
+     &     cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax)
+      data NDT0, NSTEP /0, 0/
+      data cross /.true./
+      SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML,
+     &     DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
+C
+            
+      JMR = JNP -1
+      IMJM  = IMR*JNP
+      j2 = JNP - j1 + 1
+      NSTEP = NSTEP + 1
+C
+C *********** Initialization **********************
+      if(NSTEP.eq.1) then
+c
+      write(6,*) '------------------------------------ '
+      write(6,*) 'NASA/GSFC Transport Core Version 4.5'
+      write(6,*) '------------------------------------ '
+c
+      WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1
+      WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT
+C
+C controles sur les parametres
+      if(NLAY.LT.6) then
+        write(6,*) 'NLAY must be >= 6'
+        stop
+      endif
+      if (JNP.LT.NLAY) then
+         write(6,*) 'JNP must be >= NLAY'
+        stop
+      endif
+      IMRD2=mod(IMR,2)
+      if (j1.eq.2.and.IMRD2.NE.0) then
+         write(6,*) 'if j1=2 IMR must be an even integer'
+        stop
+      endif
+
+C
+      if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then
+        write(6,*) 'Jmax or Kmax is too small'
+        stop
+      endif
+C
+      DO k=1,NLAY
+      DAP(k) = (AP(k+1) - AP(k))*PT
+      DBK(k) =  BP(k+1) - BP(k)
+      ENDDO     
+C
+      PI = 4. * ATAN(1.)
+      DL = 2.*PI / float(IMR)
+      DP =    PI / float(JMR)
+C
+      if(IGD.eq.0) then
+C Compute analytic cosine at cell edges
+            call cosa(cosp,cose,JNP,PI,DP)
+      else
+C Define cosine consistent with GEOS-GCM (using dycore2.0 or later)
+            call cosc(cosp,cose,JNP,PI,DP)
+      endif
+C
+      do 15 J=2,JMR
+15    acosp(j) = 1. / cosp(j)
+C
+C Inverse of the Scaled polar cap area.
+C
+      RCAP  = DP / (IMR*(1.-COS((j1-1.5)*DP)))
+      acosp(1)   = RCAP
+      acosp(JNP) = RCAP
+      endif
+C
+      if(NDT0 .ne. NDT) then
+      DT   = NDT
+      NDT0 = NDT
+
+	if(Umax .lt. 180.) then
+         write(6,*) 'Umax may be too small!'
+	endif
+      CR1  = abs(Umax*DT)/(DL*AE)
+      MaxDT = DP*AE / abs(Umax) + 0.5
+      write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT
+      if(MaxDT .lt. abs(NDT)) then
+            write(6,*) 'Warning!!! NDT maybe too large!'
+      endif
+C
+      if(CR1.ge.0.95) then
+      JS0 = 0
+      JN0 = 0
+      IML = IMR-2
+      ZTC = 0.
+      else
+      ZTC  = acos(CR1) * (180./PI)
+C
+      JS0 = float(JMR)*(90.-ZTC)/180. + 2
+      JS0 = max(JS0, J1+1)
+      IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
+      JN0 = JNP-JS0+1
+      endif
+C     
+C
+      do J=2,JMR
+      DTDX(j)  = DT / ( DL*AE*COSP(J) )
+
+c     print*,'dtdx=',dtdx(j)
+      DTDX5(j) = 0.5*DTDX(j)
+      enddo
+C
+      
+      DTDY  = DT /(AE*DP)
+c      print*,'dtdy=',dtdy
+      DTDY5 = 0.5*DTDY
+C
+c      write(6,*) 'J1=',J1,' J2=', J2
+      endif
+C
+C *********** End Initialization **********************
+C
+C delp = pressure thickness: the psudo-density in a hydrostatic system.
+      do  k=1,NLAY
+         do  j=1,JNP
+            do  i=1,IMR
+               delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j)
+               delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j)       
+            enddo
+         enddo
+      enddo
+          
+C
+      if(j1.ne.2) then
+      DO 40 IC=1,NC
+      DO 40 L=1,NLAY
+      DO 40 I=1,IMR
+      Q(I,  2,L,IC) = Q(I,  1,L,IC)
+40    Q(I,JMR,L,IC) = Q(I,JNP,L,IC)
+      endif
+C
+C Compute "tracer density"
+      DO 550 IC=1,NC
+      DO 44 k=1,NLAY
+      DO 44 j=1,JNP
+      DO 44 i=1,IMR
+44    DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k)
+550	continue
+C
+      do 1500 k=1,NLAY
+C
+      if(IGD.eq.0) then
+C Convert winds on A-Grid to Courant # on C-Grid.
+      call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      else
+C Convert winds on C-grid to Courant #
+      do 45 j=j1,j2
+      do 45 i=2,IMR
+45    CRX(i,J) = dtdx(j)*U(i-1,j,k)
+   
+C
+      do 50 j=j1,j2
+50    CRX(1,J) = dtdx(j)*U(IMR,j,k)
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY*V(i,1,k)
+      endif
+C     
+C Determine JS and JN
+      JS = j1
+      JN = j2
+C
+      do j=JS0,j1+1,-1
+      do i=1,IMR
+      if(abs(CRX(i,j)).GT.1.) then
+            JS = j
+            go to 2222
+      endif
+      enddo
+      enddo
+C
+2222  continue
+      do j=JN0,j2-1
+      do i=1,IMR
+      if(abs(CRX(i,j)).GT.1.) then
+            JN = j
+            go to 2233
+      endif
+      enddo
+      enddo
+2233  continue
+C
+      if(j1.ne.2) then           ! Enlarged polar cap.
+      do i=1,IMR
+      DPI(i,  2,k) = 0.
+      DPI(i,JMR,k) = 0.
+      enddo
+      endif
+C
+C ******* Compute horizontal mass fluxes ************
+C
+C N-S component
+      do j=j1,j2+1
+      D5 = 0.5 * COSE(j)
+      do i=1,IMR
+      ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k))
+      enddo
+      enddo
+C
+      do 95 j=j1,j2
+      DO 95 i=1,IMR
+95    DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
+C
+C Poles
+      sum1 = ymass(IMR,j1  )
+      sum2 = ymass(IMR,J2+1)
+      do i=1,IMR-1
+      sum1 = sum1 + ymass(i,j1  )
+      sum2 = sum2 + ymass(i,J2+1)
+      enddo
+C
+      sum1 = - sum1 * RCAP
+      sum2 =   sum2 * RCAP
+      do i=1,IMR
+      DPI(i,  1,k) = sum1
+      DPI(i,JNP,k) = sum2
+      enddo
+C
+C E-W component
+C
+      do j=j1,j2
+      do i=2,IMR
+      PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k))
+      enddo
+      enddo
+C
+      do j=j1,j2
+      PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k))
+      enddo
+C
+      do 110 j=j1,j2
+      DO 110 i=1,IMR
+110   xmass(i,j) = PU(i,j)*CRX(i,j)
+C
+      DO 120 j=j1,j2
+      DO 120 i=1,IMR-1
+120   DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j)
+C
+      DO 130 j=j1,j2
+130   DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j)
+C
+      DO j=j1,j2
+      do i=1,IMR-1
+      UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j))
+      enddo
+      enddo
+C
+      DO j=j1,j2
+      UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j))
+      enddo
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Rajouts pour LMDZ.3.3
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      do i=1,IMR
+         do j=1,JNP
+             VA(i,j)=0.
+         enddo
+      enddo
+
+      do i=1,imr*(JMR-1)
+      VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3))
+      enddo
+C
+      if(j1.eq.2) then
+	IMH = IMR/2
+      do i=1,IMH
+      VA(i,      1) = 0.5*(CRY(i,2)-CRY(i+IMH,2))
+      VA(i+IMH,  1) = -VA(i,1)
+      VA(i,    JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR))
+      VA(i+IMH,JNP) = -VA(i,JNP)
+      enddo
+      VA(IMR,1)=VA(1,1)
+      VA(IMR,JNP)=VA(1,JNP)
+      endif
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+      do 1000 IC=1,NC
+C
+      do i=1,IMJM
+      wk1(i,1,1) = 0.
+      wk1(i,1,2) = 0.
+      enddo
+C
+C E-W advective cross term
+      do 250 j=J1,J2
+      if(J.GT.JS  .and. J.LT.JN) GO TO 250
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j,k,IC)
+      enddo
+C
+      do i=-IML,0
+      qtmp(i)       = q(IMR+i,j,k,IC)
+      qtmp(IMR+1-i) = q(1-i,j,k,IC)
+      enddo
+C
+      DO 230 i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.0.) then
+      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+      else
+      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+      endif
+      wk1(i,j,1) = wk1(i,j,1) - qtmp(i)
+230   continue
+250   continue
+C
+      if(JN.ne.0) then
+      do j=JS+1,JN-1
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j,k,IC)
+      enddo
+C
+      qtmp(0)     = q(IMR,J,k,IC)
+      qtmp(IMR+1) = q(  1,J,k,IC)
+C
+      do i=1,imr
+      iu = i - UA(i,j)
+      wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1))
+      enddo
+      enddo
+      endif
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Contribution from the N-S advection
+      do i=1,imr*(j2-j1+1)
+      JT = float(J1) - VA(i,j1)
+      wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
+      enddo
+C
+      do i=1,IMJM
+      wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1)
+      wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2)
+      enddo
+C
+	if(cross) then
+C Add cross terms in the vertical direction.
+	if(IORD .GE. 2) then
+		iad = 2
+	else
+		iad = 1
+	endif
+C
+	if(JORD .GE. 2) then
+		jad = 2
+	else
+		jad = 1
+	endif
+      call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad)
+      call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad)
+      do j=1,JNP
+      do i=1,IMR
+      q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j)
+      enddo
+      enddo
+      endif
+C
+      call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2)
+     &        ,CRX,fx1,xmass,IORD)
+
+      call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY,
+     &  DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD)
+C
+1000  continue
+1500  continue
+C
+C ******* Compute vertical mass flux (same unit as PS) ***********
+C
+C 1st step: compute total column mass CONVERGENCE.
+C
+      do 320 j=1,JNP
+      do 320 i=1,IMR
+320   CRY(i,j) = DPI(i,j,1)
+C
+      do 330 k=2,NLAY
+      do 330 j=1,JNP
+      do 330 i=1,IMR
+      CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
+330   continue
+C
+      do 360 j=1,JNP
+      do 360 i=1,IMR
+C
+C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption.
+C Changes (increases) to surface pressure = total column mass convergence
+C
+      PS2(i,j)  = PS1(i,j) + CRY(i,j)
+C
+C 3rd step: compute vertical mass flux from mass conservation principle.
+C
+      W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j)
+      W(i,j,NLAY) = 0.
+360   continue
+C
+      do 370 k=2,NLAY-1
+      do 370 j=1,JNP
+      do 370 i=1,IMR
+      W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
+370   continue
+C
+      DO 380 k=1,NLAY
+      DO 380 j=1,JNP
+      DO 380 i=1,IMR
+      delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j)
+380   continue
+C
+	KRD = max(3, KORD)
+      do 4000 IC=1,NC
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+   
+      call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI,
+     &           DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD)
+C
+    
+      if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2,
+     &                     cosp,acosp,.false.,IC,NSTEP)
+C
+C Recover tracer mixing ratio from "density" using predicted
+C "air density" (pressure thickness) at time-level n+1
+C
+      DO k=1,NLAY
+      DO j=1,JNP
+      DO i=1,IMR
+            Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k)
+c            print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC)
+      enddo
+      enddo
+      enddo
+C     
+      if(j1.ne.2) then
+      DO 400 k=1,NLAY
+      DO 400 I=1,IMR
+c     j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord
+      Q(I,  2,k,IC) = Q(I,  1,k,IC)
+      Q(I,JMR,k,IC) = Q(I,JNP,k,IC)
+400   CONTINUE
+      endif
+4000  continue
+C
+      if(j1.ne.2) then
+      DO 5000 k=1,NLAY
+      DO 5000 i=1,IMR
+      W(i,  2,k) = W(i,  1,k)
+      W(i,JMR,k) = W(i,JNP,k)
+5000  continue
+      endif
+C
+      RETURN
+      END
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+      subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6,
+     &                 flux,wk1,wk2,wz2,delp,KORD)
+      parameter ( kmax = 150 )
+      parameter ( R23 = 2./3., R3 = 1./3.)
+      real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY),
+     &     wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY),
+     &     DQDT(IMR,JNP,NLAY)
+C Assuming JNP >= NLAY
+      real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*),
+     &     wz2(IMR,*)
+C
+      JMR = JNP - 1
+      IMJM = IMR*JNP
+      NLAYM1 = NLAY - 1
+C
+      LMT = KORD - 3
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Compute DC for PPM
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      do 1000 k=1,NLAYM1
+      do 1000 i=1,IMJM
+      DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
+1000  continue
+C
+      DO 1220 k=2,NLAYM1
+      DO 1220 I=1,IMJM    
+       c0 =  delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1))
+       c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k))    
+       c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k))
+      tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1))
+      Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k)
+      Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1))
+      DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp)   
+1220  CONTINUE
+     
+C     
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Loop over latitudes  (to save memory)
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 2000 j=1,JNP
+      if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000
+C
+      DO k=1,NLAY
+      DO i=1,IMR
+      wz2(i,k) =   WZ(i,j,k)
+      wk1(i,k) =    P(i,j,k)
+      wk2(i,k) = delp(i,j,k)
+      flux(i,k) = DC(i,j,k)  !this flux is actually the monotone slope
+      enddo
+      enddo
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C Compute first guesses at cell interfaces
+C First guesses are required to be continuous.
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C three-cell parabolic subgrid distribution at model top
+C two-cell parabolic with zero gradient subgrid distribution 
+C at the surface.
+C
+C First guess top edge value
+      DO 10 i=1,IMR
+C three-cell PPM
+C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
+      a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/
+     &         (wk2(i,1)+wk2(i,2)) ) /
+     &       ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) )
+      b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - 
+     &    R23*a*(2.*wk2(i,1)+wk2(i,2))
+      AL(i,1) =  wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b)
+      AL(i,2) =  wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1)
+C
+C Check if change sign
+      if(wk1(i,1)*AL(i,1).le.0.) then
+		 AL(i,1) = 0.
+             flux(i,1) = 0.
+	else
+             flux(i,1) =  wk1(i,1) - AL(i,1)
+	endif
+10    continue
+C
+C Bottom
+      DO 15 i=1,IMR
+C 2-cell PPM with zero gradient right at the surface
+C
+      fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 /
+     & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1)))
+      AR(i,NLAY) = wk1(i,NLAY) + fct
+      AL(i,NLAY) = wk1(i,NLAY) - (fct+fct)
+      if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0.
+      flux(i,NLAY) = AR(i,NLAY) -  wk1(i,NLAY)
+15    continue
+     
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C 4th order interpolation in the interior.
+C****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 14 k=3,NLAYM1
+      DO 12 i=1,IMR
+      c1 =  DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k))
+      c2 =  2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1))
+      A1   =  (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k))
+      A2   =  (wk2(i,k  )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1))
+      AL(i,k) = wk1(i,k-1) + c1 + c2 *
+     &        ( wk2(i,k  )*(c1*(A1 - A2)+A2*flux(i,k-1)) -
+     &          wk2(i,k-1)*A1*flux(i,k)  )
+C      print *,'AL1',i,k, AL(i,k)
+12    CONTINUE
+14    continue
+C
+      do 20 i=1,IMR*NLAYM1
+      AR(i,1) = AL(i,2)
+C      print *,'AR1',i,AR(i,1)
+20    continue
+C
+      do 30 i=1,IMR*NLAY
+      A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1)))
+C      print *,'A61',i,A6(i,1)
+30    continue
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C Top & Bot always monotonic
+      call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0)
+      call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY),
+     &            wk1(1,NLAY),IMR,0)
+C
+C Interior depending on KORD
+      if(LMT.LE.2)
+     &  call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2),
+     &              IMR*(NLAY-2),LMT)
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 140 i=1,IMR*NLAYM1
+      IF(wz2(i,1).GT.0.) then
+        CM = wz2(i,1) / wk2(i,1)
+        flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM))
+      else
+C        print *,'test2-0',i,j,wz2(i,1),wk2(i,2)
+        CP= wz2(i,1) / wk2(i,2)        
+C        print *,'testCP',CP
+        flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP))
+C        print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23
+      endif
+140   continue
+C
+      DO 250 i=1,IMR*NLAYM1
+      flux(i,2) = wz2(i,1) * flux(i,2)
+250   continue
+C
+      do 350 i=1,IMR
+      DQ(i,j,   1) = DQ(i,j,   1) - flux(i,   2)
+      DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY)
+350   continue
+C
+      do 360 k=2,NLAYM1
+      do 360 i=1,IMR
+360   DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
+2000  continue
+      return
+      end
+C
+      subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC,
+     &               fx1,xmass,IORD)
+      dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP)
+     &    ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML)
+      dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR)
+C
+      IMP = IMR + 1
+C
+C van Leer at high latitudes
+      jvan = max(1,JNP/18)
+      j1vl = j1+jvan
+      j2vl = j2-jvan
+C
+      do 1310 j=j1,j2
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j)
+      enddo
+C
+      if(j.ge.JN .or. j.le.JS) goto 2222
+C ************* Eulerian **********
+C
+      qtmp(0)     = q(IMR,J)
+      qtmp(-1)    = q(IMR-1,J)
+      qtmp(IMP)   = q(1,J)
+      qtmp(IMP+1) = q(2,J)
+C
+      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1406 i=1,IMR
+      iu = float(i) - uc(i,j)
+1406  fx1(i) = qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+      DC(0) = DC(IMR)
+C
+      if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then
+      DO 1408 i=1,IMR
+      iu = float(i) - uc(i,j)
+1408  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
+      else
+      call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
+      endif
+C
+      ENDIF
+C
+      DO 1506 i=1,IMR
+1506  fx1(i) = fx1(i)*xmass(i,j)
+C
+      goto 1309
+C
+C ***** Conservative (flux-form) Semi-Lagrangian transport *****
+C
+2222  continue
+C
+      do i=-IML,0
+      qtmp(i)     = q(IMR+i,j)
+      qtmp(IMP-i) = q(1-i,j)
+      enddo
+C
+      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1306 i=1,IMR
+      itmp = INT(uc(i,j))
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1306  fx1(i) = (uc(i,j) - itmp)*qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+C
+      do i=-IML,0
+      DC(i)     = DC(IMR+i)
+      DC(IMP-i) = DC(1-i)
+      enddo
+C
+      DO 1307 i=1,IMR
+      itmp = INT(uc(i,j))
+      rut  = uc(i,j) - itmp
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1307  fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut))
+      ENDIF
+C
+      do 1308 i=1,IMR
+      IF(uc(i,j).GT.1.) then
+CDIR$ NOVECTOR
+        do ist = ISAVE(i),i-1
+        fx1(i) = fx1(i) + qtmp(ist)
+        enddo
+      elseIF(uc(i,j).LT.-1.) then
+        do ist = i,ISAVE(i)-1
+        fx1(i) = fx1(i) - qtmp(ist)
+        enddo
+CDIR$ VECTOR
+      endif
+1308  continue
+      do i=1,IMR
+      fx1(i) = PU(i,j)*fx1(i)
+      enddo
+C
+C ***************************************
+C
+1309  fx1(IMP) = fx1(1)
+      DO 1215 i=1,IMR
+1215  DQ(i,j) =  DQ(i,j) + fx1(i)-fx1(i+1)
+C
+C ***************************************
+C
+1310  continue
+      return
+      end
+C
+      subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
+      DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR)
+      integer LMT 
+c      logical first
+c      data first /.true./
+c      SAVE LMT
+c      if(first) then
+C
+C correction calcul de LMT a chaque passage pour pouvoir choisir
+c plusieurs schemas PPM pour differents traceurs
+c      IF (IORD.LE.0) then
+c            if(IMR.GE.144) then
+c                  LMT = 0
+c            elseif(IMR.GE.72) then
+c                  LMT = 1
+c            else
+c                  LMT = 2
+c            endif
+c      else
+c            LMT = IORD - 3
+c      endif
+C
+      LMT = IORD - 3
+c      write(6,*) 'PPM option in E-W direction = ', LMT
+c      first = .false.
+C      endif
+C
+      DO 10 i=1,IMR
+10    AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3
+C
+      do 20 i=1,IMR-1
+20    AR(i) = AL(i+1)
+      AR(IMR) = AL(1)
+C
+      do 30 i=1,IMR
+30    A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
+C
+      if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT)
+C
+      AL(0) = AL(IMR)
+      AR(0) = AR(IMR)
+      A6(0) = A6(IMR)
+C
+      DO i=1,IMR
+      IF(UT(i).GT.0.) then
+      flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) +
+     &                 A6(i-1)*(1.-R23*UT(i)) )
+      else
+      flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) +
+     &                        A6(i)*(1.+R23*UT(i)))
+      endif
+      enddo
+      return
+      end
+C
+      subroutine xmist(IMR,IML,P,DC)
+      parameter( R24 = 1./24.)
+      dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+C
+      do 10  i=1,IMR
+      tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2))
+      Pmax = max(P(i-1), p(i), p(i+1)) - p(i)
+      Pmin = p(i) - min(P(i-1), p(i), p(i+1))
+10    DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp)
+      return
+      end
+C
+      subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2
+     &              ,ymass,fx,A6,AR,AL,JORD)
+      dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP)
+     &       ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP)
+C Work array
+      DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+C
+      JMR = JNP - 1
+      len = IMR*(J2-J1+2)
+C
+      if(JORD.eq.1) then
+      DO 1000 i=1,len
+      JT = float(J1) - VC(i,J1)
+1000  fx(i,j1) = p(i,JT)
+      else
+   
+      call ymist(IMR,JNP,j1,P,DC2,4)
+C
+      if(JORD.LE.0 .or. JORD.GE.3) then
+   
+      call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+    
+      else
+      DO 1200 i=1,len
+      JT = float(J1) - VC(i,J1)
+1200  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
+      endif
+      endif
+C
+      DO 1300 i=1,len
+1300  fx(i,j1) = fx(i,j1)*ymass(i,j1)
+C
+      DO 1400 j=j1,j2
+      DO 1400 i=1,IMR
+1400  DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j)
+C
+C Poles
+      sum1 = fx(IMR,j1  )
+      sum2 = fx(IMR,J2+1)
+      do i=1,IMR-1
+      sum1 = sum1 + fx(i,j1  )
+      sum2 = sum2 + fx(i,J2+1)
+      enddo
+C
+      sum1 = DQ(1,  1) - sum1 * RCAP
+      sum2 = DQ(1,JNP) + sum2 * RCAP
+      do i=1,IMR
+      DQ(i,  1) = sum1
+      DQ(i,JNP) = sum2
+      enddo
+C
+      if(j1.ne.2) then
+      do i=1,IMR
+      DQ(i,  2) = sum1
+      DQ(i,JMR) = sum2
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine  ymist(IMR,JNP,j1,P,DC,ID)
+      parameter ( R24 = 1./24. )
+      dimension P(IMR,JNP),DC(IMR,JNP)
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      IJM3 = IMR*(JMR-3)
+C
+      IF(ID.EQ.2) THEN
+      do 10 i=1,IMR*(JMR-1)
+      tmp = 0.25*(p(i,3) - p(i,1))
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+10    CONTINUE
+      ELSE
+      do 12 i=1,IMH
+C J=2
+      tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+C J=JMR
+      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24
+      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+12    CONTINUE
+      do 14 i=IMH+1,IMR
+C J=2
+      tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+C J=JMR
+      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24
+      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+14    CONTINUE
+C
+      do 15 i=1,IJM3
+      tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24
+      Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3)
+      Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4))
+      DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+15    CONTINUE
+      ENDIF
+C
+      if(j1.ne.2) then
+      do i=1,IMR
+      DC(i,1) = 0.
+      DC(i,JNP) = 0.
+      enddo
+      else
+C Determine slopes in polar caps for scalars!
+C
+      do 13 i=1,IMH
+C South
+      tmp = 0.25*(p(i,2) - p(i+imh,2))
+      Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1)
+      Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2))
+      DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp)
+C North.
+      tmp = 0.25*(p(i+imh,JMR) - p(i,JMR))
+      Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP)
+      Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR))
+      DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp)
+13    continue
+C
+      do 25 i=imh+1,IMR
+      DC(i,  1) =  - DC(i-imh,  1)
+      DC(i,JNP) =  - DC(i-imh,JNP)
+25    continue
+      endif
+      return
+      end
+C
+      subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
+C Local work arrays.
+      real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+      integer LMT
+c      logical first
+C      data first /.true./
+C      SAVE LMT
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      j11 = j1-1
+      IMJM1 = IMR*(J2-J1+2)
+      len   = IMR*(J2-J1+3)
+C      if(first) then
+C      IF(JORD.LE.0) then
+C            if(JMR.GE.90) then
+C                  LMT = 0
+C            elseif(JMR.GE.45) then
+C                  LMT = 1
+C            else
+C                  LMT = 2
+C            endif
+C      else
+C            LMT = JORD - 3
+C      endif
+C
+C      first = .false.
+C      endif
+C     
+c modifs pour pouvoir choisir plusieurs schemas PPM
+      LMT = JORD - 3      
+C
+      DO 10 i=1,IMR*JMR        
+      AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3
+      AR(i,1) = AL(i,2)
+10    CONTINUE
+C
+CPoles:
+C
+      DO i=1,IMH
+      AL(i,1) = AL(i+IMH,2)
+      AL(i+IMH,1) = AL(i,2)
+C
+      AR(i,JNP) = AR(i+IMH,JMR)
+      AR(i+IMH,JNP) = AR(i,JMR)
+      ENDDO
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   Rajout pour LMDZ.3.3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      AR(IMR,1)=AL(1,1)
+      AR(IMR,JNP)=AL(1,JNP)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      
+           
+      do 30 i=1,len
+30    A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
+C
+      if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11)
+     &                       ,AL(1,j11),P(1,j11),len,LMT)
+C
+     
+      DO 140 i=1,IMJM1
+      IF(VC(i,j1).GT.0.) then
+      flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) +
+     &                         A6(i,j11)*(1.-R23*VC(i,j1)) )
+      else
+      flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) +
+     &                        A6(i,j1)*(1.+R23*VC(i,j1)))
+      endif
+140   continue
+      return
+      end
+C
+	subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
+	REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
+        REAL WK(IMR,-1:JNP+2)
+C
+	JMR = JNP-1
+	IMH = IMR/2
+	do j=1,JNP
+	do i=1,IMR
+	wk(i,j) = p(i,j)
+	enddo
+	enddo
+C Poles:
+	do i=1,IMH
+	wk(i,   -1) = p(i+IMH,3)
+	wk(i+IMH,-1) = p(i,3)
+	wk(i,    0) = p(i+IMH,2)
+	wk(i+IMH,0) = p(i,2)
+	wk(i,JNP+1) = p(i+IMH,JMR)
+	wk(i+IMH,JNP+1) = p(i,JMR)
+	wk(i,JNP+2) = p(i+IMH,JNP-2)
+	wk(i+IMH,JNP+2) = p(i,JNP-2)
+	enddo
+c        write(*,*) 'toto 1' 
+C --------------------------------
+      IF(IAD.eq.2) then
+      do j=j1-1,j2+1
+      do i=1,IMR
+c      write(*,*) 'avt NINT','i=',i,'j=',j
+      JP = NINT(VA(i,j))      
+      rv = JP - VA(i,j)
+c      write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv
+      JP = j - JP
+c      write(*,*) 'JP2=',JP
+      a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp)
+      b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1))
+c      write(*,*) 'a1=',a1,'b1=',b1
+      ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j)
+      enddo
+      enddo
+c      write(*,*) 'toto 2'
+C
+      ELSEIF(IAD.eq.1) then
+	do j=j1-1,j2+1
+      do i=1,imr
+      JP = float(j)-VA(i,j)
+      ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
+      enddo
+      enddo
+      ENDIF
+C
+	if(j1.ne.2) then
+	sum1 = 0.
+	sum2 = 0.
+      do i=1,imr
+      sum1 = sum1 + ady(i,2)
+      sum2 = sum2 + ady(i,JMR)
+      enddo
+	sum1 = sum1 / IMR
+	sum2 = sum2 / IMR
+C
+      do i=1,imr
+      ady(i,  2) =  sum1
+      ady(i,JMR) =  sum2
+      ady(i,  1) =  sum1
+      ady(i,JNP) =  sum2
+      enddo
+	else
+C Poles:
+	sum1 = 0.
+	sum2 = 0.
+      do i=1,imr
+      sum1 = sum1 + ady(i,1)
+      sum2 = sum2 + ady(i,JNP)
+      enddo
+	sum1 = sum1 / IMR
+	sum2 = sum2 / IMR
+C
+      do i=1,imr
+      ady(i,  1) =  sum1
+      ady(i,JNP) =  sum2
+      enddo
+	endif
+C
+	return
+	end
+C
+	subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD)
+	REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
+C
+	JMR = JNP-1
+      do 1309 j=j1,j2
+      if(J.GT.JS  .and. J.LT.JN) GO TO 1309
+C
+      do i=1,IMR
+      qtmp(i) = p(i,j)
+      enddo
+C
+      do i=-IML,0
+      qtmp(i)       = p(IMR+i,j)
+      qtmp(IMR+1-i) = p(1-i,j)
+      enddo
+C
+      IF(IAD.eq.2) THEN
+      DO i=1,IMR
+      IP = NINT(UA(i,j))
+      ru = IP - UA(i,j)
+      IP = i - IP
+      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+      adx(i,j) = qtmp(ip) + ru*(a1*ru + b1)
+      enddo
+      ELSEIF(IAD.eq.1) then
+      DO i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.0.) then
+      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+      else
+      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+      endif
+      enddo
+      ENDIF
+C
+      do i=1,IMR
+      adx(i,j) = adx(i,j) - p(i,j)
+      enddo
+1309  continue
+C
+C Eulerian upwind
+C
+      do j=JS+1,JN-1
+C
+      do i=1,IMR
+      qtmp(i) = p(i,j)
+      enddo
+C
+      qtmp(0)     = p(IMR,J)
+      qtmp(IMR+1) = p(1,J)
+C
+      IF(IAD.eq.2) THEN
+      qtmp(-1)     = p(IMR-1,J)
+      qtmp(IMR+2) = p(2,J)
+      do i=1,imr
+      IP = NINT(UA(i,j))
+      ru = IP - UA(i,j)
+      IP = i - IP
+      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+      adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1)
+      enddo
+      ELSEIF(IAD.eq.1) then
+C 1st order
+      DO i=1,IMR
+      IP = i - UA(i,j)
+      adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1))
+      enddo
+      ENDIF
+      enddo
+C
+	if(j1.ne.2) then
+      do i=1,IMR
+      adx(i,  2) = 0.
+      adx(i,JMR) = 0.
+      enddo
+	endif
+C set cross term due to x-adv at the poles to zero.
+      do i=1,IMR
+      adx(i,  1) = 0.
+      adx(i,JNP) = 0.
+      enddo
+	return
+	end
+C
+      subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT)
+C
+C A6 =  CURVATURE OF THE TEST PARABOLA
+C AR =  RIGHT EDGE VALUE OF THE TEST PARABOLA
+C AL =  LEFT  EDGE VALUE OF THE TEST PARABOLA
+C DC =  0.5 * MISMATCH
+C P  =  CELL-AVERAGED VALUE
+C IM =  VECTOR LENGTH
+C
+C OPTIONS:
+C
+C LMT = 0: FULL MONOTONICITY
+C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS)
+C LMT = 2: POSITIVE-DEFINITE CONSTRAINT
+C
+      parameter ( R12 = 1./12. )
+      dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+C
+      if(LMT.eq.0) then
+C Full constraint
+      do 100 i=1,IM
+      if(DC(i).eq.0.) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      else
+      da1  = AR(i) - AL(i)
+      da2  = da1**2
+      A6DA = A6(i)*da1
+      if(A6DA .lt. -da2) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      elseif(A6DA .gt. da2) then
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+      endif
+100   continue
+      elseif(LMT.eq.1) then
+C Semi-monotonic constraint
+      do 150 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. AL(i)) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      else
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+150   continue
+      elseif(LMT.eq.2) then
+      do 250 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250
+      fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
+      if(fmin.ge.0.) go to 250
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. AL(i)) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      else
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+250   continue
+      endif
+      return
+      end
+C
+      subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*)
+C
+      do 35 j=j1,j2
+      do 35 i=2,IMR
+35    CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
+C
+      do 45 j=j1,j2
+45    CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
+      return
+      end
+C
+      subroutine cosa(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+      JMR = JNP-1
+      do 55 j=2,JNP
+        ph5  =  -0.5*PI + (FLOAT(J-1)-0.5)*DP
+55      cose(j) = cos(ph5)
+C
+      JEQ = (JNP+1) / 2
+      if(JMR .eq. 2*(JMR/2) ) then
+      do j=JNP, JEQ+1, -1
+       cose(j) =  cose(JNP+2-j)
+      enddo
+      else
+C cell edge at equator.
+       cose(JEQ+1) =  1.
+      do j=JNP, JEQ+2, -1
+       cose(j) =  cose(JNP+2-j)
+       enddo
+      endif
+C
+      do 66 j=2,JMR
+66    cosp(j) = 0.5*(cose(j)+cose(j+1))
+      cosp(1) = 0.
+      cosp(JNP) = 0.
+      return
+      end
+C
+      subroutine cosc(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+C
+      phi = -0.5*PI
+      do 55 j=2,JNP-1
+      phi  =  phi + DP
+55    cosp(j) = cos(phi)
+        cosp(  1) = 0.
+        cosp(JNP) = 0.
+C
+      do 66 j=2,JNP
+        cose(j) = 0.5*(cosp(j)+cosp(j-1))
+66    CONTINUE
+C
+      do 77 j=2,JNP-1
+       cosp(j) = 0.5*(cose(j)+cose(j+1))
+77    CONTINUE
+      return
+      end
+C
+      SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp,
+     &                   cross,IC,NSTEP)
+C
+      parameter( tiny = 1.E-60 )
+      DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
+      logical cross
+C
+      NLAYM1 = NLAY-1
+      len = IMR*(j2-j1+1)
+      ip = 0
+C
+C Top layer
+      L = 1
+	icr = 1
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 50
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 50
+C
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 50
+C
+C Vertical filling...
+      do i=1,len
+      IF( Q(i,j1,1).LT.0.) THEN
+      ip = ip + 1
+          Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1)
+          Q(i,j1,1) = 0.
+      endif
+      enddo
+C
+50    continue
+      DO 225 L = 2,NLAYM1
+      icr = 1
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 225
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) go to 225
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 225
+C
+      do i=1,len
+      IF( Q(I,j1,L).LT.0.) THEN
+C
+      ip = ip + 1
+C From above
+          qup =  Q(I,j1,L-1)
+          qly = -Q(I,j1,L)
+          dup  = min(qly,qup)
+          Q(I,j1,L-1) = qup - dup
+          Q(I,j1,L  ) = dup-qly
+C Below
+          Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L)
+          Q(I,j1,L)   = 0.
+      ENDIF
+      ENDDO
+225   CONTINUE
+C
+C BOTTOM LAYER
+      sum = 0.
+      L = NLAY
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 911
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 911
+C
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      if(icr.eq.0) goto 911
+C
+      DO  I=1,len
+      IF( Q(I,j1,L).LT.0.) THEN
+      ip = ip + 1
+c
+C From above
+C
+          qup = Q(I,j1,NLAYM1)
+          qly = -Q(I,j1,L)
+          dup = min(qly,qup)
+          Q(I,j1,NLAYM1) = qup - dup
+C From "below" the surface.
+          sum = sum + qly-dup
+          Q(I,j1,L) = 0.
+       ENDIF
+      ENDDO
+C
+911   continue
+C
+      if(ip.gt.IMR) then
+      write(6,*) 'IC=',IC,' STEP=',NSTEP,
+     &           ' Vertical filling pts=',ip
+      endif
+C
+      if(sum.gt.1.e-25) then
+      write(6,*) IC,NSTEP,' Mass source from the ground=',sum
+      endif
+      RETURN
+      END
+C
+      subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+      icr = 0
+      do 65 j=j1+1,j2-1
+      DO 50 i=1,IMR-1
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-E
+      dn = q(i+1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i+1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-E
+      ds = q(i+1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i+1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+50    continue
+      if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65
+      DO 55 i=2,IMR
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-W
+      dn = q(i-1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i-1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-W
+      ds = q(i-1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i-1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+55    continue
+C *****************************************
+C i=1
+      i=1
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-W
+      dn = q(IMR,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(IMR,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-W
+      ds = q(IMR,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(IMR,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+C *****************************************
+C i=IMR
+      i=IMR
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-E
+      dn = q(1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-E
+      ds = q(1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+C *****************************************
+65    continue
+C
+      do i=1,IMR
+      if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then
+      icr = 1
+      goto 80
+      endif
+      enddo
+C
+80    continue
+C
+      if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then
+      icr = 1
+      endif
+C
+      return
+      end
+C
+      subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+c      logical first
+c      data first /.true./
+c      save cap1
+C
+c      if(first) then
+      DP = 4.*ATAN(1.)/float(JNP-1)
+      CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
+c      first = .false.
+c      endif
+C
+      ipy = 0
+      do 55 j=j1+1,j2-1
+      DO 55 i=1,IMR
+      IF(q(i,j).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j)*cosp(j)
+C North
+      dn = q(i,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C South
+      ds = q(i,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+55    continue
+C
+      do i=1,imr
+      IF(q(i,j1).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j1)*cosp(j1)
+C North
+      dn = q(i,j1+1)*cosp(j1+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i,j1+1) = (dn - d1)*acosp(j1+1)
+      q(i,j1) = (d1 - dq)*acosp(j1) + tiny
+      endif
+      enddo
+C
+      j = j2
+      do i=1,imr
+      IF(q(i,j).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j)*cosp(j)
+C South
+      ds = q(i,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+      enddo
+C
+C Check Poles.
+      if(q(1,1).lt.0.) then
+      dq = q(1,1)*cap1/float(IMR)*acosp(j1)
+      do i=1,imr
+      q(i,1) = 0.
+      q(i,j1) = q(i,j1) + dq
+      if(q(i,j1).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      if(q(1,JNP).lt.0.) then
+      dq = q(1,JNP)*cap1/float(IMR)*acosp(j2)
+      do i=1,imr
+      q(i,JNP) = 0.
+      q(i,j2) = q(i,j2) + dq
+      if(q(i,j2).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      dimension q(IMR,*),qtmp(JNP,IMR)
+C
+      ipx = 0
+C Copy & swap direction for vectorization.
+      do 25 i=1,imr
+      do 25 j=j1,j2
+25    qtmp(j,i) = q(i,j)
+C
+      do 55 i=2,imr-1
+      do 55 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,i-1))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,i-1) = qtmp(j,i-1) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,i+1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,i+1) = qtmp(j,i+1) - d2
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+55    continue
+c
+      i=1
+      do 65 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,imr))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,imr) = qtmp(j,imr) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,i+1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,i+1) = qtmp(j,i+1) - d2
+c
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+65    continue
+      i=IMR
+      do 75 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,i-1))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,i-1) = qtmp(j,i-1) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,1) = qtmp(j,1) - d2
+c
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+75    continue
+C
+      if(ipx.ne.0) then
+      do 85 j=j1,j2
+      do 85 i=1,imr
+85    q(i,j) = qtmp(j,i)
+      else
+C
+C Poles.
+      if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1
+      endif
+      return
+      end
+C
+      subroutine zflip(q,im,km,nc)
+C This routine flip the array q (in the vertical).
+      real q(im,km,nc)
+C local dynamic array
+      real qtmp(im,km)
+C
+      do 4000 IC = 1, nc
+C
+      do 1000 k=1,km
+      do 1000 i=1,im
+      qtmp(i,k) = q(i,km+1-k,IC)
+1000  continue
+C
+      do 2000 i=1,im*km
+2000  q(i,1,IC) = qtmp(i,1)
+4000  continue
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/prather.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/prather.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/prather.F	(revision 984)
@@ -0,0 +1,361 @@
+!
+! $Header$
+!
+      SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
+      IMPLICIT NONE
+
+c=======================================================================
+c   Adaptation LMDZ:  A.Armengaud (LGGE)
+c   ----------------
+c
+c   ************************************************
+c   Transport des traceurs par la methode de prather
+c   Ref : 
+c
+c   ************************************************
+c   q,w,pext,pbaru et pbarv : arguments d'entree  pour le s-pg
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iq,nt
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL masse(iip1,jjp1,llm)
+      REAL q( iip1,jjp1,llm,0:9)
+      REAL w( ip1jmp1,llm )
+      integer ordre,ilim
+
+c   Local:
+c   ------
+      LOGICAL limit
+      real zq(iip1,jjp1,llm)
+      REAL sm ( iip1,jjp1, llm )
+      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+      REAL sxx( iip1,jjp1,llm)
+      REAL sxy( iip1,jjp1,llm)
+      REAL sxz( iip1,jjp1,llm)
+      REAL syy( iip1,jjp1,llm )
+      REAL syz( iip1,jjp1,llm )
+      REAL szz( iip1,jjp1,llm ),zz
+      INTEGER i,j,l,indice
+      real sxn(iip1),sxs(iip1)
+
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      real qmin,qmax
+      save qmin,qmax
+      save sinlon,coslon,sinlondlon,coslondlon
+      real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps
+      real masn,mass
+c
+      REAL      SSUM
+      integer ismax,ismin
+      EXTERNAL  SSUM, convflu,ismin,ismax
+      logical first
+      save first
+      EXTERNAL advxp,advyp,advzp 
+
+
+      data first/.true./
+      data qmin,qmax/-1.e33,1.e33/
+
+
+c==========================================================================
+c==========================================================================
+c     MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt
+c==========================================================================
+c==========================================================================
+      REAL dt
+c==========================================================================
+      limit = .TRUE.
+ 
+      if(first) then
+         print*,'SCHEMA PRATHER'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+
+        DO l = 1,llm
+        DO j = 1,jjp1
+        DO i = 1,iip1
+        q( i,j,l,1 )=0.
+        q( i,j,l,2)=0.
+        q( i,j,l,3)=0.
+        q( i,j,l,4)=0.
+        q( i,j,l,5)=0.
+        q( i,j,l,6)=0.
+        q( i,j,l,7)=0.
+        q( i,j,l,8)=0.
+        q( i,j,l,9)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      endif
+c   Fin modif Fred
+
+c *** On calcule la masse d'air en kg
+
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+         sm( i,j,llm+1-l ) =masse(i,j,l)
+         ENDDO
+        ENDDO
+       ENDDO
+
+c *** q contient les qqtes de traceur avant l'advection 
+
+c *** Affectation des tableaux S a partir de Q
+ 
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+       s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l)
+       sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l)
+       sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l)
+       sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l)
+       sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l)
+       sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l)
+       sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l)
+       syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l)
+       syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l)
+       szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l)
+         ENDDO
+        ENDDO
+       ENDDO
+c *** Appel des subroutines d'advection en X, en Y et en Z
+c *** Advection avec "time-splitting"
+      
+c-----------------------------------------------------------
+       do indice =1,nt
+       call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        end do
+        do l=1,llm
+        do i=1,iip1
+        sy(i,1,l)=0.
+        sy(i,jjp1,l)=0.
+        enddo
+        enddo
+c---------------------------------------------------------
+       call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+c---------------------------------------------------------
+
+c---------------------------------------------------------
+       do j=1,jjp1
+          do i=1,iip1
+             sz(i,j,1)=0.
+             sz(i,j,llm)=0.
+             sxz(i,j,1)=0.
+             sxz(i,j,llm)=0.
+             syz(i,j,1)=0.
+             syz(i,j,llm)=0.
+             szz(i,j,1)=0.
+             szz(i,j,llm)=0.
+          enddo
+       enddo
+       call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz 
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        do l=1,llm
+        do i=1,iip1
+        sy(i,1,l)=0.
+        sy(i,jjp1,l)=0.
+        enddo
+        enddo
+
+c---------------------------------------------------------
+
+c---------------------------------------------------------
+       call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+c---------------------------------------------------------
+       DO l = 1,llm
+        DO j = 1,jjp1
+             s0( iip1,j,l)=s0( 1,j,l )
+             sx( iip1,j,l)=sx( 1,j,l )
+             sy( iip1,j,l)=sy( 1,j,l )
+             sz( iip1,j,l)=sz( 1,j,l )
+             sxx( iip1,j,l)=sxx( 1,j,l )
+             sxy( iip1,j,l)=sxy( 1,j,l) 
+             sxz( iip1,j,l)=sxz( 1,j,l )
+             syy( iip1,j,l)=syy( 1,j,l )
+             syz( iip1,j,l)=syz( 1,j,l)
+             szz( iip1,j,l)=szz( 1,j,l )
+        ENDDO
+       ENDDO
+       do indice=1,nt
+       call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        end do
+c---------------------------------------------------------
+c---------------------------------------------------------
+c ***   On repasse les S dans la variable qpr
+c ***   On repasse les S dans la variable q directement 14/10/94
+
+       DO  l = 1,llm
+        DO  j = 1,jjp1
+         DO  i = 1,iip1
+      q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l)
+      ENDDO
+      ENDDO
+      ENDDO
+
+c---------------------------------------------------------
+c      go to  777
+c   filtrages aux poles
+
+c Traitements specifiques au pole
+
+c   filtrages aux poles
+         DO l=1,llm
+c   filtrages aux poles
+         masn=ssum(iim,sm(1,1,l),1)
+         mass=ssum(iim,sm(1,jjp1,l),1)
+         qpn=ssum(iim,s0(1,1,l),1)/masn
+         qps=ssum(iim,s0(1,jjp1,l),1)/mass
+         dqzpn=ssum(iim,sz(1,1,l),1)/masn
+         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+         do i=1,iip1
+          q( i,1,llm+1-l,3)=dqzpn
+          q( i,jjp1,llm+1-l,3)=dqzps
+          q( i,1,llm+1-l,0)=qpn
+          q( i,jjp1,llm+1-l,0)=qps
+         enddo
+c       enddo
+c         print*,'qpn',qpn,'qps',qps
+c          print*,'dqzpn',dqzpn,'dqzps',dqzps
+c       enddo
+           dyn1=0.
+           dys1=0.
+           dyn2=0.
+           dys2=0.
+        do i=1,iim
+        zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+        dyn1=dyn1+sinlondlon(i)*zz
+        dyn2=dyn2+coslondlon(i)*zz
+        zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+        dys1=dys1+sinlondlon(i)*zz
+        dys2=dys2+coslondlon(i)*zz
+        enddo
+         do i=1,iim
+         q(i,1,llm+1-l,2)=
+     $   (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+         q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)
+     $          +q(i,1,llm+1-l,2)
+         q(i,jjp1,llm+1-l,2)=
+     $   (sinlon(i)*dys1+coslon(i)*dys2)/2.
+         q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     $      -q(i,jjp1,llm+1-l,2)
+         enddo
+      q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+      q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+      do i=1,iim
+      sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+      sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+      enddo
+      sxn(iip1)=sxn(1)
+      sxs(iip1)=sxs(1)
+      do i=1,iim
+      q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+      q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+      END DO
+      q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+      q(1,jjp1,llm+1-l,1)=
+     $   q(iip1,jjp1,llm+1-l,1)
+        enddo
+         do l=1,llm
+           do i=1,iim
+            q( i,1,llm+1-l,4)=0.
+            q( i,jjp1,llm+1-l,4)=0.
+            q( i,1,llm+1-l,5)=0.
+            q( i,jjp1,llm+1-l,5)=0.
+            q( i,1,llm+1-l,6)=0.
+            q( i,jjp1,llm+1-l,6)=0.
+            q( i,1,llm+1-l,7)=0.
+            q( i,jjp1,llm+1-l,7)=0.
+            q( i,1,llm+1-l,8)=0.
+            q( i,jjp1,llm+1-l,8)=0.
+            q( i,1,llm+1-l,9)=0.
+            q( i,jjp1,llm+1-l,9)=0.
+          enddo
+         ENDDO
+
+777      continue
+c
+c   bouclage en longitude
+      do l=1,llm
+      do j=1,jjp1
+      q(iip1,j,l,0)=q(1,j,l,0)
+      q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0)
+      q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1)
+      q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2)
+      q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3)
+      q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4)
+      q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5)
+      q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6)
+      q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7)
+      q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8)
+      q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9)
+      enddo
+      enddo
+        DO l = 1,llm
+    	 DO j = 2,jjm
+           DO i = 1,iip1
+         IF (q(i,j,l,0).lt.0.)  THEN
+         PRINT*,'------------ BIP-----------' 
+         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0),
+     $          q(i,j-1,l,0)
+         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2),
+     $   q(i,j-1,l,2)   
+         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+c    		     PRINT*,' PBL EN SORTIE D'' ADVZP'
+                     q(i,j,l,0)=0.
+c                  STOP
+               ENDIF
+           ENDDO
+         ENDDO
+         do j=1,jjp1,jjm
+         do i=1,iip1
+               IF (q(i,j,l,0).lt.0.)  THEN
+               PRINT*,'------------ BIP 2-----------'
+         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0)
+         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2)
+         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+
+                     q(i,j,l,0)=0.
+c                  STOP
+               ENDIF
+         enddo
+         enddo
+        ENDDO
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/pres2lev.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/pres2lev.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/pres2lev.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+c******************************************************
+      SUBROUTINE   pres2lev(varo,varn,lmo,lmn,po,pn,
+     %                      ni,nj)
+c
+c interpolation lineaire pour passer
+c a une nouvelle discretisation verticale pour
+c les variables de GCM
+c Francois Forget (01/1995)
+c 
+c MOdif remy roca 12/97 pour passer de pres2sig
+c**********************************************************
+
+      IMPLICIT NONE
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+
+       INTEGER lmo ! dimensions ancienne couches (input)
+       INTEGER lmn ! dimensions nouvelle couches (input)
+       INTEGER lmomx ! dimensions ancienne couches (input)
+       INTEGER lmnmx ! dimensions nouvelle couches (input)
+
+       parameter(lmomx=10000,lmnmx=10000)
+
+        real po(lmo)! niveau de pression en millibars
+        real pn(ni,nj,lmn) ! niveau de pression en pascals
+
+       INTEGER i,j,Nhoriz,ni,nj ! nombre de point horizontale (input)
+
+       REAL varo(ni,nj,lmo) ! var dans l'ancienne grille (input)
+       REAL varn(ni,nj,lmn) ! var dans la nouvelle grille (output)
+
+       real zvaro(lmomx),zpo(lmomx)
+
+c Autres variables
+c """"""""""""""""
+       INTEGER n, ln ,lo 
+       REAL coef
+
+c run
+c ====
+        do i=1,ni
+        do j=1,nj
+c a chaque point de grille correspond un nouveau sigma old
+c qui vaut pres(l)/ps(i,j)
+           do lo=1,lmo
+              zpo(lo)=po(lmo+1-lo)
+              zvaro(lo)=varo(i,j,lmo+1-lo)
+           enddo
+        
+           do ln=1,lmn
+              if (pn(i,j,ln).ge.zpo(1))then
+                 varn(i,j,ln) =  zvaro(1)
+              else if (pn(i,j,ln).le.zpo(lmo)) then
+                 varn(i,j,ln) =  zvaro(lmo)
+              else
+                 do lo=1,lmo-1 
+                    if ( (pn(i,j,ln).le.zpo(lo)).and.
+     &                 (pn(i,j,ln).gt.zpo(lo+1)) )then
+                       coef=(pn(i,j,ln)-zpo(lo))
+     &                 /(zpo(lo+1)-zpo(lo))
+                       varn(i,j,ln)=zvaro(lo)
+     &                 +coef*(zvaro(lo+1)-zvaro(lo))
+c       print*,'pn(',ln,')=',pn(i,j,ln),varn(i,j,ln)
+                    end if
+                 enddo           
+              endif
+           enddo
+
+        enddo
+        enddo
+      return
+      end    
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/pression.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/pression.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/pression.F	(revision 984)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+      SUBROUTINE pression( ngrid, ap, bp, ps, p )
+c
+
+c      Auteurs : P. Le Van , Fr.Hourdin  .
+
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+      INTEGER ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      DO    l    = 1, llmp1
+        DO  ij   = 1, ngrid
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+   
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/profvert.def
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/profvert.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/profvert.def	(revision 984)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+nom_courbes=F
+titre=/home/hourdin/LMDZ4/libf/dyn3d
+xinf=0.
+xsup=669.
+yinf=6.5
+ysup=10.5
+axtxtx=sols
+axtxty=pressure (mb)
+pathcham=.
+lstyles=1 9999
+linewidth=.2
+lcolors=1 9999
+frwidth=.5
+repery0=T
+txtheight=2.5
+freecoord=/d2/hourdin/Ames/saison.def
+
+determination du champ physique
+xlength=195.
+ylength=105.
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/psextbar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/psextbar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/psextbar.F	(revision 984)
@@ -0,0 +1,107 @@
+!
+! $Header$
+!
+      SUBROUTINE psextbar ( ps, psexbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c **********************************************************************
+c
+c         ps          est un  argum. d'entree  pour le s-pg ..
+c         psexbarxy   est un  argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )
+
+      INTEGER  l, ij
+c
+
+      DO ij = 1, ip1jmp1
+       pext(ij) = ps(ij) * aire(ij)
+      ENDDO
+
+
+      DO     5     ij = 1, ip1jm - 1
+      psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     psexbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      psexbarxy( ij ) = psexbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/q_sat.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/q_sat.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/q_sat.F	(revision 984)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+c
+c
+
+      subroutine q_sat(np,temp,pres,qsat)
+c
+      IMPLICIT none
+c======================================================================
+c Autheur(s): Z.X. Li (LMD/CNRS)
+c  reecriture vectorisee par F. Hourdin.
+c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+c======================================================================
+c Arguments:
+c kelvin---input-R: temperature en Kelvin
+c millibar--input-R: pression en mb
+c
+c q_sat----output-R: vapeur d'eau saturante en kg/kg
+c======================================================================
+c
+      integer np
+      REAL temp(np),pres(np),qsat(np)
+c
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+c
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+c
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+c
+      REAL rtt
+      PARAMETER (rtt=273.16)
+c
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+
+      real zqsat
+      integer ip
+c
+C     ------------------------------------------------------------------
+c
+c
+
+      do ip=1,np
+
+c      write(*,*)'kelvin,millibar=',kelvin,millibar
+c       write(*,*)'temp,pres=',temp(ip),pres(ip)
+c
+         IF (temp(ip) .LE. rtt) THEN
+            r3es = r3ies
+            r4es = r4ies
+         ELSE
+            r3es = r3les
+            r4es = r4les
+         ENDIF
+c
+         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+         zqsat=MIN(0.5,ZQSAT)
+         zqsat=zqsat/(1.-retv *zqsat)
+c
+         qsat(ip)= zqsat
+c      write(*,*)'qsat=',qsat(ip)
+
+      enddo
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/qminimum.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/qminimum.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/qminimum.F	(revision 984)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE qminimum( q,nq,deltap )
+
+      IMPLICIT none
+c
+c  -- Objet : Traiter les valeurs trop petites (meme negatives)
+c             pour l'eau vapeur et l'eau liquide
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+c
+      INTEGER nq
+      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide
+c
+c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+c            parametres seuil_vap, seuil_liq soient pareilles a celles 
+c            qui  sont utilisees dans la routine    ADDFI       )
+c     .................................................................
+c
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+c
+      REAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+c
+c Quand l'eau liquide est trop petite (ou negative), on prend
+c l'eau vapeur de la meme couche et la convertit en eau liquide
+c (sans changer la temperature !)
+c
+      DO 1000 k = 1, llm
+      DO 1040 i = 1, ip1jmp1
+            zx_defau      = AMAX1( seuil_liq - q(i,k,iq_liq), 0.0 )
+            q(i,k,iq_vap) = q(i,k,iq_vap) - zx_defau
+            q(i,k,iq_liq) = q(i,k,iq_liq) + zx_defau
+ 1040 CONTINUE
+ 1000 CONTINUE
+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
+      iq = iq_vap
+c
+      DO k = llm, 2, -1
+ccc      zx_abc = dpres(k) / dpres(k-1)
+      DO i = 1, ip1jmp1
+         zx_abc = deltap(i,k)/deltap(i,k-1)
+         zx_defau    = AMAX1( seuil_vap - q(i,k,iq), 0.0 )
+         q(i,k-1,iq) =  q(i,k-1,iq) - zx_defau * zx_abc
+         q(i,k,iq)   =  q(i,k,iq)   + zx_defau  
+      ENDDO
+      ENDDO
+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
+      DO i = 1, ip1jmp1
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+      ENDDO
+      pompe = SSUM(ip1jmp1,zx_pump,1)
+      IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN
+         WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
+         DO i = 1, ip1jmp1
+            IF (zx_pump(i).GT.0.0) THEN
+               imprim = imprim + 1
+               PRINT*,'QMINIMUM:  en ',i,zx_pump(i)
+            ENDIF
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ran1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ran1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ran1.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      FUNCTION RAN1(IDUM)
+      DIMENSION R(97)
+      save r
+      save iff,ix1,ix2,ix3
+      PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6)
+      PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6)
+      PARAMETER (M3=243000,IA3=4561,IC3=51349)
+      DATA IFF /0/
+      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)=(FLOAT(IX1)+FLOAT(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)PAUSE
+      RAN1=R(J)
+      R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/read_reanalyse.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/read_reanalyse.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/read_reanalyse.F	(revision 984)
@@ -0,0 +1,530 @@
+!
+! $Header$
+!
+c
+c
+      subroutine read_reanalyse(timestep,psi
+     s   ,u,v,t,q,masse,ps,mode,nlevnc)
+
+c   mode=0 variables naturelles
+c   mode=1 variabels GCM
+
+c -----------------------------------------------------------------
+c   Declarations
+c -----------------------------------------------------------------
+      IMPLICIT NONE
+
+c common
+c ------
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "guide.h"
+
+
+c arguments
+c ---------
+      integer nlevnc
+      integer timestep,mode,l
+
+      real psi(iip1,jjp1)
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+
+
+c local
+c -----
+      integer ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps
+      integer ncidpl
+      integer varidpl,ncidQ,varidQ
+      save ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps
+      save ncidpl
+      save varidpl,ncidQ,varidQ
+
+      real*4 unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
+      real*4 tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
+      real*4 Qnc(iip1,jjp1,nlevnc)
+      real*4 pl(nlevnc)
+
+      integer start(4),count(4),status
+
+      real rcode
+      logical first
+      save first
+
+      data first/.true./
+
+
+
+c -----------------------------------------------------------------
+c   Initialisation de la lecture des fichiers
+c -----------------------------------------------------------------
+      if (first) then
+           ncidpl=-99
+           print*,'Intitialisation de read reanalsye'
+
+c Vent zonal
+            if (guide_u) then
+            ncidu=NCOPN('u.nc',NCNOWRIT,rcode)
+            varidu=NCVID(ncidu,'UWND',rcode)
+            print*,'ncidu,varidu',ncidu,varidu
+            if (ncidpl.eq.-99) ncidpl=ncidu
+            endif
+
+c Vent meridien
+            if (guide_v) then
+            ncidv=NCOPN('v.nc',NCNOWRIT,rcode)
+            varidv=NCVID(ncidv,'VWND',rcode)
+            print*,'ncidv,varidv',ncidv,varidv
+            if (ncidpl.eq.-99) ncidpl=ncidv
+            endif
+
+c Temperature
+            if (guide_T) then
+            ncidt=NCOPN('T.nc',NCNOWRIT,rcode)
+            varidt=NCVID(ncidt,'AIR',rcode)
+            print*,'ncidt,varidt',ncidt,varidt
+            if (ncidpl.eq.-99) ncidpl=ncidt
+            endif
+
+c Humidite
+            if (guide_Q) then
+            ncidQ=NCOPN('hur.nc',NCNOWRIT,rcode)
+            varidQ=NCVID(ncidQ,'RH',rcode)
+            print*,'ncidQ,varidQ',ncidQ,varidQ
+            if (ncidpl.eq.-99) ncidpl=ncidQ
+            endif
+
+c Pression de surface
+            if (guide_P) then
+            ncidps=NCOPN('ps.nc',NCNOWRIT,rcode)
+            varidps=NCVID(ncidps,'SP',rcode)
+            print*,'ncidps,varidps',ncidps,varidps
+            endif
+
+c Coordonnee verticale
+            if (ncep) then
+               print*,'Vous etes entrain de lire des donnees NCEP'
+               varidpl=NCVID(ncidpl,'LEVEL',rcode)
+            else
+               print*,'Vous etes entrain de lire des donnees ECMWF'
+               varidpl=NCVID(ncidpl,'PRESSURE',rcode)
+            endif
+            print*,'ncidu,varidpl',ncidu,varidpl
+      endif
+      print*,'ok1'
+
+c Niveaux de pression
+      print*,'WARNING!!! Il n y a pas de test de coherence'
+      print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,pl)
+#else
+      status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,pl)
+#endif
+c  passage en pascal
+      pl(:)=100.*pl(:)
+      if (first) then
+       do l=1,nlevnc
+          print*,'PL(',l,')=',pl(l)
+       enddo
+      endif
+
+c -----------------------------------------------------------------
+c   lecture des champs u, v, T, ps
+c -----------------------------------------------------------------
+
+c  dimensions pour les champs scalaires et le vent zonal
+c  -----------------------------------------------------
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=timestep
+
+      count(1)=iip1
+      count(2)=jjp1
+      count(3)=nlevnc
+      count(4)=1
+
+c mise a zero des tableaux 
+c ------------------------
+       unc(:,:,:)=0.
+       vnc(:,:,:)=0.
+       tnc(:,:,:)=0.
+       Qnc(:,:,:)=0.
+
+c  Vent zonal
+c  ----------
+
+      if (guide_u) then
+      print*,'avant la lecture de UNCEP nd de niv:',nlevnc
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unc)
+#else
+      status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unc)
+#endif
+c     call dump2d(iip1,jjp1,unc,'VENT NCEP   ')
+c     call dump2d(iip1,40,unc(1,1,nlevnc),'VENT NCEP   ')
+      print*,'WARNING!!! Correction bidon pour palier a un '
+      print*,'probleme dans la creation des fichiers nc'
+      call correctbid(iim,jjp1*nlevnc,unc)
+      call dump2d(iip1,jjp1,unc,'UNC COUCHE 1 ')
+      endif
+
+c  Temperature
+c  -----------
+
+      print*,'ncidt=',ncidt,'varidt=',varidt,'start=',start
+      print*,'count=',count
+      if (guide_T) then
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnc)
+#else
+      status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnc)
+#endif
+      call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 AAA ')
+      call correctbid(iim,jjp1*nlevnc,tnc)
+      call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 BBB ')
+      endif
+
+c  Humidite
+c  --------
+
+      if (guide_Q) then
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,Qnc)
+#else
+      status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,Qnc)
+#endif
+      call correctbid(iim,jjp1*nlevnc,Qnc)
+      call dump2d(iip1,jjp1,Qnc,'QNC COUCHE 1 ')
+      endif
+
+      count(2)=jjm
+c  Vent meridien
+c  -------------
+
+      if (guide_v) then
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnc)
+#else
+      status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnc)
+#endif
+      call correctbid(iim,jjm*nlevnc,vnc)
+      call dump2d(iip1,jjm,vnc,'VNC COUCHE 1 ')
+      endif
+
+      start(3)=timestep
+      start(4)=0
+      count(2)=jjp1
+      count(3)=1
+      count(4)=0
+
+c  Pression de surface
+c  -------------------
+
+      if (guide_P) then
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnc)
+#else
+      status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnc)
+#endif
+      call dump2d(iip1,jjp1,psnc,'PSNC COUCHE 1 ')
+      call correctbid(iim,jjp1,psnc)
+      endif
+
+
+
+c -----------------------------------------------------------------
+c  Interpollation verticale sur les niveaux modele
+c -----------------------------------------------------------------
+      call reanalyse2nat(nlevnc,psi,unc,vnc,tnc,Qnc,psnc,pl,u,v,t,Q
+     s    ,ps,masse,pk)
+
+      call dump2d(iip1,jjm,v,'V COUCHE APRES ')
+
+
+c -----------------------------------------------------------------
+c  Passage aux variables du modele (vents covariants, temperature
+c  potentielle et humidite specifique)
+c -----------------------------------------------------------------
+      call nat2gcm(u,v,t,Q,pk,u,v,t,Q)
+      print*,'TIMESTEP ',timestep
+      if(mode.ne.1) stop'mode pas egal 0'
+c     call dump2d(iip1,jjm,v,'VCOV COUCHE 1 ')
+
+c   Lignes introduites a une epoque pour un probleme oublie...
+c     do l=1,llm
+c        do i=1,iip1
+c           v(i,1,l)=0.
+c           v(i,jjm,l)=0.
+c        enddo
+c     enddo
+      first=.false.
+
+      return
+      end
+
+
+c===========================================================================
+      subroutine reanalyse2nat(nlevnc,psi
+     s   ,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q
+     s   ,ps,masse,pk)
+c===========================================================================
+
+c -----------------------------------------------------------------
+c   Inversion Nord/sud de la grille + interpollation sur les niveaux
+c   verticaux du modele.
+c -----------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "guide.h"
+
+      integer nlevnc
+      real psi(iip1,jjp1)
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm)
+
+      real pl(nlevnc)
+      real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
+      real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
+      real qnc(iip1,jjp1,nlevnc)
+
+      real zu(iip1,jjp1,llm),zv(iip1,jjm,llm)
+      real zt(iip1,jjp1,llm),zq(iip1,jjp1,llm)
+
+      real pext(iip1,jjp1,llm)
+      real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm)
+      real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm)
+      real plsnc(iip1,jjp1,llm)
+
+      REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm)
+      real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1)
+      real pkf(iip1,jjp1,llm)
+      real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm)
+      real prefkap,unskap
+
+
+      integer i,j,l
+
+
+c -----------------------------------------------------------------
+c   calcul de la pression au milieu des couches.
+c -----------------------------------------------------------------
+
+      CALL pression( ip1jmp1, ap, bp, psi, p )
+      call massdair(p,masse)
+      CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
+
+c    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+      unskap=1./kappa
+      prefkap =  preff  ** kappa
+c     PRINT *,' Pref kappa unskap  ',preff,kappa,unskap
+      DO l = 1, llm
+       DO j=1,jjp1
+        DO i =1, iip1
+        pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+        ENDDO
+       ENDDO
+       ENDDO
+
+
+c -----------------------------------------------------------------
+c   calcul des pressions pour les grilles u et v
+c -----------------------------------------------------------------
+
+      do l=1,llm
+      do j=1,jjp1
+         do i=1,iip1
+            pext(i,j,l)=pls(i,j,l)*aire(i,j)
+         enddo
+      enddo
+      enddo
+      call massbar(pext, pbarx, pbary )
+      do l=1,llm
+      do j=1,jjp1
+         do i=1,iip1
+            plunc(i,jjp1+1-j,l)=pbarx(i,j,l)/aireu(i,j)
+            plsnc(i,jjp1+1-j,l)=pls(i,j,l)
+         enddo
+      enddo
+      enddo
+      do l=1,llm
+      do j=1,jjm
+         do i=1,iip1
+            plvnc(i,jjm+1-j,l)=pbary(i,j,l)/airev(i,j)
+         enddo
+      enddo
+      enddo
+
+c -----------------------------------------------------------------
+
+      if (guide_P) then
+      do j=1,jjp1
+         do i=1,iim
+            ps(i,j)=psnc(i,jjp1+1-j)
+         enddo
+         ps(iip1,j)=ps(1,j)
+      enddo
+      endif
+
+
+c -----------------------------------------------------------------
+      call pres2lev(unc,zu,nlevnc,llm,pl,plunc,iip1,jjp1)
+      call pres2lev(vnc,zv,nlevnc,llm,pl,plvnc,iip1,jjm )
+      call pres2lev(tnc,zt,nlevnc,llm,pl,plsnc,iip1,jjp1)
+      call pres2lev(qnc,zq,nlevnc,llm,pl,plsnc,iip1,jjp1)
+
+c     call dump2d(iip1,jjp1,ps,'PS    ')
+c     call dump2d(iip1,jjp1,psu,'PS    ')
+c     call dump2d(iip1,jjm,psv,'PS    ')
+c  Inversion Nord/Sud
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iim
+               u(i,j,l)=zu(i,jjp1+1-j,l)
+               t(i,j,l)=zt(i,jjp1+1-j,l)
+               q(i,j,l)=zq(i,jjp1+1-j,l)
+            enddo
+            u(iip1,j,l)=u(1,j,l)
+            t(iip1,j,l)=t(1,j,l)
+            q(iip1,j,l)=q(1,j,l)
+         enddo
+      enddo
+
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               v(i,j,l)=zv(i,jjm+1-j,l)
+            enddo
+            v(iip1,j,l)=v(1,j,l)
+         enddo
+      enddo
+
+      return
+      end
+
+c===========================================================================
+      subroutine nat2gcm(u,v,t,rh,pk,ucov,vcov,teta,q)
+c===========================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "guide.h"
+
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),pk(iip1,jjp1,llm),rh(iip1,jjp1,llm)
+      real ps(iip1,jjp1)
+
+      real ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm),q(iip1,jjp1,llm)
+
+      real pres(iip1,jjp1,llm),qsat(iip1,jjp1,llm)
+
+      real unskap
+
+      integer i,j,l
+
+
+      print*,'Entree dans nat2gcm'
+c    ucov(:,:,:)=0.
+c    do l=1,llm
+c       ucov(:,2:jjm,l)=u(:,2:jjm,l)*cu(:,2:jjm)
+c    enddo
+c    ucov(iip1,:,:)=ucov(1,:,:)
+
+c    teta(:,:,:)=t(:,:,:)*cpp/pk(:,:,:)
+c    teta(iip1,:,:)=teta(1,:,:)
+     
+c   calcul de ucov et de la temperature potentielle
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iim
+               ucov(i,j,l)=u(i,j,l)*cu(i,j)
+               teta(i,j,l)=t(i,j,l)*cpp/pk(i,j,l)
+            enddo
+            ucov(iip1,j,l)=ucov(1,j,l)
+            teta(iip1,j,l)=teta(1,j,l)
+         enddo
+         do i=1,iip1
+            ucov(i,1,l)=0.
+            ucov(i,jjp1,l)=0.
+            teta(i,1,l)=teta(1,1,l)
+            teta(i,jjp1,l)=teta(1,jjp1,l)
+         enddo
+      enddo
+
+c   calcul de ucov
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               vcov(i,j,l)=v(i,j,l)*cv(i,j)
+            enddo
+            vcov(iip1,j,l)=vcov(1,j,l)
+         enddo
+      enddo
+
+c     call dump2d(iip1,jjp1,teta,'TETA EN BAS   ')
+c     call dump2d(iip1,jjp1,teta(1,1,llm),'TETA EN HAUT   ')
+
+c  Humidite relative -> specifique
+c  -------------------------------
+      if (1.eq.0) then
+c   FINALEMENT ON GUIDE EN HUMIDITE RELATIVE
+      print*,'calcul de unskap'
+      unskap   = 1./ kappa
+      print*,'calcul de pres'
+      pres(:,:,:)=preff*(pk(:,:,:)/cpp)**unskap
+      print*,'calcul de qsat'
+      call q_sat(iip1*jjp1*llm,t,pres,qsat)
+      print*,'calcul de q'
+c   ATTENTION : humidites relatives en %
+      rh(:,:,:)=max(rh(:,:,:)*0.01,1.e-6)
+      q(:,:,:)=qsat(:,:,:)*rh(:,:,:)
+      print*,'calcul de q OK'
+
+      call dump2d(iip1,jjp1,pres,'PRESSION PREMIERE COUCHE   ')
+      call dump2d(iip1,jjp1,q,'HUMIDITE SPECIFIQUE COUCHE 1   ') 
+      endif
+
+
+      return
+      end
+
+
+
+c===========================================================================
+      subroutine correctbid(iim,nl,x)
+c===========================================================================
+      integer iim,nl
+      real x(iim+1,nl)
+      integer i,l
+      real zz
+
+      do l=1,nl
+         do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+c              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+      enddo
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/rotat.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/rotat.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/rotat.F	(revision 984)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE rotat (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/rotat_nfil.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/rotat_nfil.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/rotat_nfil.F	(revision 984)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      SUBROUTINE rotat_nfil (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van 
+c**************************************************************
+c.          Calcule le rotationnel  non filtre   ,
+c      a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/rotatf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/rotatf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/rotatf.F	(revision 984)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE rotatf (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/rotatst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/rotatst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/rotatst.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE rotatst (klevel,x, y, rot )
+c
+c  P. Le Van
+c
+c    *****************************************************************
+c     .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y ..
+c         x  et  y etant des composantes  covariantes  .....
+c    *****************************************************************
+c        x  et y     sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+      INTEGER klevel
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+      INTEGER  l, ij
+c
+c
+      DO 5 l = 1,klevel
+c
+      DO 1 ij = 1, ip1jm - 1
+      rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   +
+     *                 x(ij +iip1, l )  -  x( ij,l )  )
+   1  CONTINUE
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim,l )
+   2  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/serre.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/serre.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/serre.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+c
+c
+c..include serre.h
+c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , 
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/sort.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/sort.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/sort.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3d/sortvarc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/sortvarc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/sortvarc.F	(revision 984)
@@ -0,0 +1,165 @@
+!
+! $Header$
+!
+      SUBROUTINE sortvarc
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       ge(:)=dp(:)*dp(:)
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot  = SSUM(     llm, etotl, 1 )
+      ztot  = SSUM(     llm, ztotl, 1 )
+      stot  = SSUM(     llm, stotl, 1 )
+      rmsv  = SSUM(     llm, rmsvl, 1 )
+      ang   = SSUM(     llm,  angl, 1 )
+
+      rday = FLOAT(INT ( day_ini + time ))
+c
+      IF(ptot0.eq.0.)  THEN
+         PRINT 3500, itau, rday, heure,time
+         PRINT*,'WARNING!!! On recalcule les valeurs initiales de :'
+         PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
+         PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+         etot0 = etot
+         ptot0 = ptot
+         ztot0 = ztot
+         stot0 = stot
+         ang0  = ang
+      END IF
+
+      etot= etot/etot0
+      rmsv= SQRT(rmsv/ptot)
+      ptot= ptot/ptot0
+      ztot= ztot/ztot0
+      stot= stot/stot0
+      ang = ang /ang0
+
+
+      PRINT 3500, itau, rday, heure, time
+      PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+
+      RETURN
+
+3500   FORMAT('0'10(1h*),4x,'pas'i7,5x,'jour'f5.0,'heure'f5.1,4x 
+     *   ,'date',f10.5,4x,10(1h*))
+4000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie'
+     * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB  '
+     .  ,f10.6,e13.6,5f10.3/
+     * )
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/sortvarc0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/sortvarc0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/sortvarc0.F	(revision 984)
@@ -0,0 +1,141 @@
+!
+! $Header$
+!
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+      integer  ismin,ismax
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       ge=dp*dp
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot0  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot0  = SSUM(     llm, etotl, 1 )
+      ztot0  = SSUM(     llm, ztotl, 1 )
+      stot0  = SSUM(     llm, stotl, 1 )
+      rmsv   = SSUM(     llm, rmsvl, 1 )
+      ang0   = SSUM(     llm,  angl, 1 )
+
+      rday = FLOAT(INT ( day_ini + time ))
+c
+      PRINT 3500, itau, rday, heure, time
+      PRINT *, ptot0,etot0,ztot0,stot0,ang0
+
+3500   FORMAT('0',10(1h*),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x 
+     *   ,'date',f10.5,4x,10(1h*))
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/spline.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/spline.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/spline.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      subroutine spline(x,y,n,yp1,ypn,y2)
+     
+c
+     
+c     Routine to set up the interpolating function for a cubic spline
+     
+c     interpolation (see "Numerical Recipes" for details).
+     
+c
+	  implicit real (a-h,o-z)
+	  implicit integer (i-n)
+     
+      parameter(nllm=4096)
+     
+      dimension x(n),y(n),y2(n),u(nllm)
+     
+c
+c	write(6,*)(x(i),i=1,n)
+c	write(6,*)(y(i),i=1,n)
+     
+      if(yp1.gt.0.99E30) then
+c the lower boundary condition is set
+       y2(1)=0.
+c either to be "natural"
+       u(1)=0.
+     
+      else
+c or else to have a specified first
+       y2(1)=-0.5
+c derivative
+       u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+     
+      end if
+     
+      do 11 i=2,n-1
+c decomposition loop of the tridiagonal
+       sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+c algorithm. Y2 and U are used
+       p=sig*y2(i-1)+2.
+c for temporary storage of the decompo-
+       y2(i)=(sig-1.)/p
+c sed factors
+       u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
+     
+     . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+     
+ 11   continue
+     
+      if(ypn.gt.0.99E30) then
+c the upper boundary condition is set
+       qn=0.
+c either to be "natural"
+       un=0.
+     
+      else
+c or else to have a specified first
+       qn=0.5
+c derivative
+       un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+     
+      end if
+     
+      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+     
+      do 12 k=n-1,1,-1
+c this is the backsubstitution loop of
+       y2(k)=y2(k)*y2(k+1)+u(k)
+c the tridiagonal algorithm
+ 12   continue
+     
+c
+     
+      return
+     
+      end
+     
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/splint.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/splint.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/splint.F	(revision 984)
@@ -0,0 +1,56 @@
+!
+! $Header$
+!
+     
+      SUBROUTINE splint(xa,ya,y2a,n,x,y)
+     
+c
+c     Routine to compute a cubic-spline interpolated value Y given the
+c     value of X, the arrays XA, YA and the 2nd derivative array Y2A
+c     computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details
+c
+     
+      IMPLICIT REAL (a-h,o-z)
+      IMPLICIT INTEGER (i-n)
+      DIMENSION xa(n),ya(n),y2a(n)
+     
+      kl0=1
+     
+      khi=n
+c means of bisection
+ 1    IF(khi-kl0.gt.1) THEN
+     
+       k=(khi+kl0)/2
+     
+       IF(xa(k).gt.x) THEN
+     
+        khi=k
+     
+       ELSE
+     
+        kl0=k
+     
+       END IF
+     
+       GO TO 1
+     
+      END IF
+c KL0 and KHI now bracket the X
+      h=xa(khi)-xa(kl0)
+     
+      IF(h.eq.0.0) STOP
+      a=(xa(khi)-x)/h
+c evaluation of cubic spline polynomial
+      b=(x-xa(kl0))/h
+     
+      y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2)
+     
+     ./6.
+     
+c
+     
+      RETURN
+     
+      END
+     
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/startvar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/startvar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/startvar.F	(revision 984)
@@ -0,0 +1,1191 @@
+!
+! $Header$
+!
+C
+C
+      MODULE startvar
+    !
+    !
+    !      There are three ways to access data from the database of atmospheric data which 
+    !       can be used to initialize the model. This depends on the type of field which needs 
+    !       to be extracted. In any case the call should come after a restget and should be of the type :
+    !                CALL startget(...)
+    !
+    !       We will details the possible arguments to startget here :
+    !
+    !        - A 2D variable on the dynamical grid :
+    !           CALL startget(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar )             
+    !
+    !        - A 1D variable on the physical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         - A 3D variable on the dynamical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         There is special constraint on the atmospheric data base except that the 
+    !         the data needs to be in netCDF and the variables should have the the following 
+    !        names in the file :
+    !
+    !      'RELIEF'  : High resolution orography 
+    !       'ST'            : Surface temperature
+    !       'CDSW'     : Soil moisture
+    !       'Z'               : Surface geopotential
+    !       'SP'            : Surface pressure
+    !        'U'              : East ward wind
+    !        'V'              : Northward wind
+    !        'TEMP'             : Temperature
+    !        'R'             : Relative humidity
+    !      
+      USE ioipsl
+    !
+    !
+      IMPLICIT NONE
+    !
+    !
+      PRIVATE
+      PUBLIC startget
+    !
+    !
+      INTERFACE startget
+        MODULE PROCEDURE startget_phys2d, startget_phys1d, startget_dyn
+      END INTERFACE
+    !
+      INTEGER, SAVE :: fid_phys, fid_dyn
+      INTEGER, SAVE  :: iml_phys, iml_rel, iml_dyn
+      INTEGER, SAVE :: jml_phys,  jml_rel, jml_dyn
+      INTEGER, SAVE ::  llm_dyn, ttm_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lon_phys, lon_rug,
+     . lon_alb, lon_rel, lon_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lat_phys, lat_rug,
+     . lat_alb, lat_rel, lat_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:)  :: levdyn_ini
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: relief, zstd, zsig,
+     . zgam, zthe, zpic, zval
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rugo, masque, phis
+    !
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: tsol, qsol, psol_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)  ::   var_ana3d
+    !
+      CONTAINS
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in,
+     . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu )
+    !
+    !    There is a big mess with the size in logitude, should it be iml or iml+1.
+    !    I have chosen to use the iml+1 as an argument to this routine and we declare
+    !   internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. 
+    !  A convention is required.
+    !
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(iml,jml)
+      REAL, INTENT(in) :: val_exp
+      REAL, INTENT(in), optional :: masque_lu(iml,jml) 
+      LOGICAL interbar
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. 
+     .MINVAL(champ(:,:)).EQ.val_exp ) THEN
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('relief')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(relief)) THEN
+                      !
+                    if (present(masque_lu)) then
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar, masque_lu )
+                    else
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar)
+                    endif
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(relief) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 'STARTVAR module has been',
+     .' initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = relief(:,:)
+                  !
+              CASE ('rugosite')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(rugo)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(rugo) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = rugo(:,:)
+                  !
+              CASE ('masque')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(masque)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                     jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(masque) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .   'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = masque(:,:)
+                  !
+              CASE ('surfgeo')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = phis(:,:)
+                  !
+              CASE ('psol')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                      !
+                      CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = psol_dyn(:,:)
+                  !
+              CASE DEFAULT
+                  !
+                  WRITE(*,*) 'startget_phys2d'
+                  WRITE(*,*) 'No rule is present to extract variable', 
+     .                 varname(:LEN_TRIM(varname)),' from any data set'
+                  STOP
+                  !
+          END SELECT
+          !
+      ELSE
+          !
+          ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we
+          ! will catch them
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('surfgeo')
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      ALLOCATE(phis(iml,jml))
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  phis(:,:) = champ(:,:)
+                  !
+          END SELECT
+          !
+      ENDIF
+    !
+      END SUBROUTINE startget_phys2d
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 ,
+     ,   lat_in2 , interbar, masque_lu )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, intent(in), optional :: masque_lu(iml,jml)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      LOGICAL interbar2
+      REAL :: lev(1), date, dt,chmin,chmax
+      INTEGER :: itau(1), fid
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+      INTEGER :: iret
+      CHARACTER*25 title
+      REAL, ALLOCATABLE :: relief_hi(:,:)
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: tmp_var(:,:)
+      INTEGER, ALLOCATABLE :: tmp_int(:,:)
+    !
+      CHARACTER*120 :: orogfname
+      LOGICAL :: check=.TRUE.
+    !
+    !
+      orogfname = 'Relief.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Reading the high resolution orography'
+    !
+      CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)
+    !
+      ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret)
+    !
+      CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, 
+     .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp,
+     .      itau, date, dt, fid)
+    !
+      CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, 
+     . ttm_tmp, 1, 1, relief_hi)
+    !
+      CALL flinclo(fid)
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_rel))
+      ALLOCATE(lon_ini(iml_rel))
+
+      IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_rel(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_rel))
+      ALLOCATE(lat_ini(jml_rel))
+
+      IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_rel(1,:) 
+      ENDIF
+    !
+    !
+
+      title='RELIEF'
+
+      interbar2 = .FALSE.
+      CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini,
+     . lon_rad, lat_rad, relief_hi , interbar2  )
+
+      IF ( check ) WRITE(*,*) 'Computes all the parameters needed',
+     .' for the gravity wave drag code'
+    !
+    !    Allocate the data we need to put in the interpolated fields
+    !
+    !            RELIEF:  orographie moyenne
+      ALLOCATE(relief(iml,jml))
+    !            zphi :  orographie moyenne
+      ALLOCATE(phis(iml,jml))
+    !             zstd:  deviation standard de l'orographie sous-maille
+      ALLOCATE(zstd(iml,jml))
+    !             zsig:  pente de l'orographie sous-maille 
+      ALLOCATE(zsig(iml,jml))
+    !             zgam:  anisotropy de l'orographie sous maille
+      ALLOCATE(zgam(iml,jml))
+    !             zthe:  orientation de l'axe oriente dans la direction
+    !                    de plus grande pente de l'orographie sous maille
+      ALLOCATE(zthe(iml,jml))
+    !             zpic:  hauteur pics de la SSO
+      ALLOCATE(zpic(iml,jml))
+    !             zval:  hauteur vallees de la SSO
+      ALLOCATE(zval(iml,jml))
+    !             masque : Masque terre ocean
+      ALLOCATE(tmp_int(iml,jml))
+      ALLOCATE(masque(iml,jml))
+
+      masque = -99999.
+      if (present(masque_lu)) then
+        masque = masque_lu
+      endif
+    !
+      CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, 
+     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque)
+      phis = phis * 9.81
+    !
+!      masque(:,:) = FLOAT(tmp_int(:,:))
+    !
+    !  Compute surface roughness
+    !
+      IF ( check ) WRITE(*,*) 
+     .'Compute surface roughness induced by the orography'
+    !
+      ALLOCATE(rugo(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, tmp_var)
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          rugo(i,j) = tmp_var(i,j)
+        ENDDO
+        rugo(iml,j) = tmp_var(1,j)
+      ENDDO
+c
+cc   ***   rugo  n'est pas utilise pour l'instant  ******
+    !
+    !   Build land-sea mask
+    !
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_orog
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, 
+     .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar)
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, nbindex, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(nbindex)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. 
+     .MINVAL(champ(:)).EQ.val_exp ) THEN
+          SELECTCASE(varname)
+            CASE ('tsol')
+              IF ( .NOT.ALLOCATED(tsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2, lat_in2, interbar )
+              ENDIF
+              IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ)
+            CASE ('qsol')
+              IF ( .NOT.ALLOCATED(qsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ)
+            CASE ('psol')
+              IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ)
+            CASE ('zmea')
+              IF ( .NOT.ALLOCATED(relief)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ)
+            CASE ('zstd')
+              IF ( .NOT.ALLOCATED(zstd)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ)
+            CASE ('zsig')
+              IF ( .NOT.ALLOCATED(zsig)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .               jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ)
+            CASE ('zgam')
+              IF ( .NOT.ALLOCATED(zgam)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ)
+            CASE ('zthe')
+              IF ( .NOT.ALLOCATED(zthe)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ)
+            CASE ('zpic')
+              IF ( .NOT.ALLOCATED(zpic)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ)
+            CASE ('zval')
+              IF ( .NOT.ALLOCATED(zval)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ)
+            CASE ('rads')
+                  champ(:) = 0.0
+            CASE ('snow')
+                  champ(:) = 0.0
+cIM "slab" ocean
+            CASE ('tslab')
+                   champ(:) = 0.0
+            CASE ('seaice')
+                  champ(:) = 0.0
+            CASE ('rugmer')
+                  champ(:) = 0.001
+            CASE ('agsno')
+                  champ(:) = 50.0
+            CASE DEFAULT
+              WRITE(*,*) 'startget_phys1d'
+              WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+              STOP
+          END SELECT
+      ELSE
+        !
+        ! If we see tsol we catch it as we may need it for a 3D interpolation
+        !
+        SELECTCASE(varname)
+          CASE ('tsol')
+            IF ( .NOT.ALLOCATED(tsol)) THEN
+              ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) ))
+            ENDIF
+            CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol)
+        END SELECT
+      ENDIF
+      END SUBROUTINE startget_phys1d
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2,
+     .                 lon_in2, lat_in2 , interbar )
+    !
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+!ac     REAL :: lev(1), date, dt
+      REAL :: date, dt
+      REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini
+!ac
+      INTEGER :: itau(1)
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+    !
+      CHARACTER*25 title
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:)
+    !
+      physfname = 'ECPHY.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp,
+     . ttm_tmp, fid_phys)
+    !
+      ALLOCATE (lat_phys(iml_phys,jml_phys))
+      ALLOCATE (lon_phys(iml_phys,jml_phys))
+!ac
+      ALLOCATE (levphys_ini(llm_tmp))
+    !
+!      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+!     . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, 
+!     . itau, date, dt, fid_phys)
+    !
+      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+     . llm_tmp, lon_phys, lat_phys, levphys_ini, ttm_tmp, 
+     . itau, date, dt, fid_phys)
+    !
+      DEALLOCATE (levphys_ini)
+!ac
+    !
+    ! Allocate the space we will need to get the data out of this file
+    !
+      ALLOCATE(var_ana(iml_phys, jml_phys))
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_phys))
+      ALLOCATE(lon_ini(iml_phys))
+
+      IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_phys(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_phys))
+      ALLOCATE(lat_ini(jml_phys))
+
+      IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_phys(1,:) 
+      ENDIF
+
+
+    !
+    !   We get the two standard varibales
+    !   Surface temperature
+    !
+      ALLOCATE(tsol(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+    !
+
+      CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, 
+     .llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='ST'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana , interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  ST $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad ,
+     ,   var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var   ) 
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, tsol, iml-1, jml)
+    !
+    ! Soil moisture
+    !
+      ALLOCATE(qsol(iml,jml))
+      CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys,
+     . llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='CDSW'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  CDSW $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad ,
+     ,   var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var  )
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+c
+        CALL gr_int_dyn(tmp_var, qsol, iml-1, jml)
+    !
+       CALL flinclo(fid_phys)
+    !
+      END SUBROUTINE start_init_phys
+    !
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+    !
+      SUBROUTINE startget_dyn(varname, iml, jml, lon_in, lat_in,
+     . lml, pls, workvar, champ, val_exp,jml2, lon_in2, lat_in2 ,
+     ,  interbar )
+    !
+    !   ARGUMENTS
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, lml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(in) :: pls(iml, jml, lml)
+      REAL, INTENT(in) :: workvar(iml, jml, lml)
+      REAL, INTENT(inout) :: champ(iml, jml, lml)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !    LOCAL
+    !
+      INTEGER :: il, ij, ii
+      REAL :: xppn, xpps
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND.
+     . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN
+        !
+        SELECTCASE(varname)
+          CASE ('u')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .          lon_in2,lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('U', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ,interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('v')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, 
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('V', iml, jml, lml, lon_in, 
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('t')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 ,interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+ 
+          CASE ('tpot')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 ,
+     .            lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) )
+     .                                    THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = champ(ii,ij,il) * cpp 
+     .                                 / workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute potential temperature as the'
+              WRITE(*,*)'Exner function is missing or constant.'
+              STOP
+            ENDIF
+          CASE ('q')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in,
+     .        jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) 
+     .                                     THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = 0.01 * champ(ii,ij,il) *
+     .                                       workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              WHERE ( champ .LT. 0.) champ = 1.0E-10
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute specific humidity as the'
+              WRITE(*,*)'saturated humidity is missing or constant.'
+              STOP
+            ENDIF
+          CASE DEFAULT
+            WRITE(*,*) 'startget_dyn'
+            WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+            STOP
+          END SELECT
+      ENDIF
+      END SUBROUTINE startget_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 ,
+     ,             lat_in2 , interbar )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1)
+      INTEGER :: i, j
+      integer :: iret
+    !
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:)
+      REAL, ALLOCATABLE :: xppn(:), xpps(:)
+      LOGICAL :: allo
+    !
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+      CHARACTER*25 title
+
+    !
+      physfname = 'ECDYN.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn,
+     .                            ttm_dyn, fid_dyn)
+      IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, 
+     .                                         llm_dyn, ttm_dyn
+    !
+      ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (levdyn_ini(llm_dyn), stat=iret)
+    !
+      CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn,
+     . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, 
+     . itau, date, dt, fid_dyn)
+    !
+
+      allo = allocated (var_ana)
+      if (allo) then
+        DEALLOCATE(var_ana, stat=iret)
+      endif
+      ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret)
+
+      allo = allocated (lon_rad)
+      if (allo) then
+        DEALLOCATE(lon_rad, stat=iret)
+      endif
+
+      ALLOCATE(lon_rad(iml_dyn), stat=iret)
+      ALLOCATE(lon_ini(iml_dyn))
+       
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+
+      ALLOCATE(z(iml, jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+c
+      title='Z'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+c
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  Z  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad ,
+     ,    var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .               iml-1, jml, lon_in, lat_in, tmp_var)
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, z, iml-1, jml)
+    !
+      ALLOCATE(psol_dyn(iml, jml))
+    !
+      CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+
+       title='SP'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  SP  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad ,
+     ,    var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .             iml-1, jml, lon_in, lat_in, tmp_var  )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml)
+    !
+      IF ( .NOT.ALLOCATED(tsol)) THEN
+    !   These variables may have been allocated by the need to 
+    !   create a start field for them or by the varibale
+    !   coming out of the restart file. In case we dor have it we will initialize it.
+    !
+        CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2,
+     .                 lat_in2 , interbar )
+      ELSE
+        IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN
+        WRITE(*,*) 'start_init_dyn :'
+        WRITE(*,*) 'The temperature field we have does not ',
+     .             'have the right size'
+        STOP
+      ENDIF
+      ENDIF
+      IF ( .NOT.ALLOCATED(phis)) THEN
+            !
+            !    These variables may have been allocated by the need to create a start field for them or by the varibale
+            !     coming out of the restart file. In case we dor have it we will initialize it.
+            !
+        CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 ,
+     .      lat_in2 , interbar )
+            !
+      ELSE
+            !
+          IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN
+                !
+              WRITE(*,*) 'start_init_dyn :'
+              WRITE(*,*) 'The orography field we have does not ',
+     .                   ' have the right size'
+              STOP
+          ENDIF
+            !
+      ENDIF
+    !
+    !     PSOL is computed in Pascals
+    !
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) 
+     .                    /287.0/tsol(i,j))
+        ENDDO
+        psol_dyn(iml,j) = psol_dyn(1,j)
+      ENDDO
+    !
+    !
+      ALLOCATE(xppn(iml-1))
+      ALLOCATE(xpps(iml-1)) 
+    !
+      DO  i   = 1, iml-1
+        xppn(i) = aire( i,1) * psol_dyn( i,1)
+        xpps(i) = aire( i,jml) * psol_dyn( i,jml)
+      ENDDO
+    !
+      DO i   = 1, iml
+        psol_dyn(i,1    )  = SUM(xppn)/apoln
+        psol_dyn(i,jml)  = SUM(xpps)/apols
+      ENDDO
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in,
+     .      lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar )
+    !
+    !    This subroutine gets a variables from a 3D file and does the interpolations needed
+    !
+    !
+    !    ARGUMENTS
+    !
+      CHARACTER*(*) :: varname
+      INTEGER :: iml, jml, lml, jml2
+      REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml)
+      REAL :: lon_in2(iml) , lat_in2(jml2)
+      REAL :: var3d(iml, jml, lml)
+      LOGICAL interbar
+      real chmin,chmax
+    !
+    !  LOCAL
+    !
+      CHARACTER*25 title
+      INTEGER :: ii, ij, il, jsort,i,j,l
+      REAL :: bx, by
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:)
+      REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:)
+      REAL, ALLOCATABLE :: ax(:), ay(:), yder(:)
+!       REAL, ALLOCATABLE :: varrr(:,:,:)
+      INTEGER, ALLOCATABLE :: lind(:)
+    !
+      LOGICAL :: check = .TRUE.
+    !
+      IF ( .NOT. ALLOCATED(var_ana3d)) THEN
+          ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn))
+      ENDIF
+!          ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn))
+    !
+    !
+      IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ',
+     .  ' field.', fid_dyn
+      IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn,
+     .                        llm_dyn,ttm_dyn
+    !
+      CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, 
+     . ttm_dyn, 1, 1, var_ana3d)
+    !
+      IF ( check) WRITE(*,*) 'Allocating space for the interpolation',
+     . iml, jml, llm_dyn
+    !
+      ALLOCATE(lon_rad(iml_dyn))
+      ALLOCATE(lon_ini(iml_dyn))
+
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      ALLOCATE(lev_dyn(llm_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+      CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, 
+     . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d  ,
+     ,  interbar                                                   )
+
+      ALLOCATE(var_tmp2d(iml-1, jml))
+      ALLOCATE(var_tmp3d(iml, jml, llm_dyn))
+      ALLOCATE(ax(llm_dyn))
+      ALLOCATE(ay(llm_dyn))
+      ALLOCATE(yder(llm_dyn))
+      ALLOCATE(lind(llm_dyn))
+    !
+ 
+      DO il=1,llm_dyn
+        !
+      IF( interbar )  THEN
+       IF( il.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour ', varname
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+       ENDIF
+       CALL inter_barxy ( iml_dyn, jml_dyn -1,lon_rad, lat_rad, 
+     , var_ana3d(:,:,il),iml-1, jml2, lon_in2, lat_in2,jml,var_tmp2d ) 
+      ELSE
+       CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, 
+     .  var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d )
+      ENDIF
+        !
+        CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml)
+        !
+       ENDDO
+       !
+          DO il=1,llm_dyn
+            lind(il) = llm_dyn-il+1
+          ENDDO
+    !
+c
+c  ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere
+c                    vers  le  sol  ...
+c
+      DO ij=1,jml
+        DO ii=1,iml-1
+          !
+          ax(:) = lev_dyn(lind(:)) 
+          ay(:) = var_tmp3d(ii, ij, lind(:))
+          !
+         
+          CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder)
+          !
+          DO il=1,lml
+            bx = pls_in(ii, ij, il)
+            CALL SPLINT(ax, ay, yder, llm_dyn, bx, by)
+            var3d(ii, ij, il) = by
+          ENDDO
+          !
+        ENDDO
+        var3d(iml, ij, :) = var3d(1, ij, :) 
+      ENDDO
+
+      do il=1,lml
+        call minmax(iml*jml,var3d(1,1,il),chmin,chmax)
+      SELECTCASE(varname)
+       CASE('U')
+          WRITE(*,*) ' U  min max l ',il,chmin,chmax
+       CASE('V')
+          WRITE(*,*) ' V  min max l ',il,chmin,chmax
+       CASE('TEMP')
+          WRITE(*,*) ' TEMP  min max l ',il,chmin,chmax
+       CASE('R')
+          WRITE(*,*) ' R  min max l ',il,chmin,chmax
+      END SELECT
+           enddo
+
+      DEALLOCATE(lon_rad)
+      DEALLOCATE(lon_ini)
+      DEALLOCATE(lat_rad)
+      DEALLOCATE(lat_ini)
+      DEALLOCATE(lev_dyn)
+      DEALLOCATE(var_tmp2d)
+      DEALLOCATE(var_tmp3d)
+      DEALLOCATE(ax)
+      DEALLOCATE(ay)
+      DEALLOCATE(yder)
+      DEALLOCATE(lind)
+
+    !
+      RETURN
+    !
+      END SUBROUTINE start_inter_3d
+    !
+      END MODULE startvar
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/temps.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/temps.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/temps.h	(revision 984)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref,   &
+     &             itau_dyn, itau_phy
+
+      INTEGER   itaufin
+      INTEGER*4 itau_dyn, itau_phy
+      INTEGER*4 day_ini, day_end, annee_ref, day_ref
+      REAL      dt
+
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/test_period.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/test_period.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/test_period.F	(revision 984)
@@ -0,0 +1,114 @@
+!
+! $Header$
+!
+      SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
+c
+c     Auteur : P. Le Van  
+c    ---------
+c  ....  Cette routine teste la periodicite en longitude des champs   ucov,
+c                           teta, q , p et phis                 .......... 
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+c    ......  Arguments   ......
+c
+      REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) ,
+     ,      q(ip1jmp1,llm,nqmx), p(ip1jmp1,llmp1), phis(ip1jmp1)
+c
+c   .....  Variables  locales  .....
+c
+      INTEGER ij,l,nq
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( ucov(ij,l).NE.ucov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  UCOV  ---  n est pas',  
+     ,  ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( teta(ij,l).NE.teta(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,   ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+     ,      , teta(ij,l),   teta(ij+iim,l)
+          STOP
+          ENDIF
+         ENDDO
+
+         do ij=1,iim
+          if (teta(ij,l).ne.teta(1,l)
+     s     .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,  ' constant aux poles ! '
+          print*,'teta(',1 ,',',l,')=',teta(1 ,l)
+          print*,'teta(',ij,',',l,')=',teta(ij,l)
+          print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l)
+          print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l)
+          stop
+          endif
+         enddo
+      ENDDO
+
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jm, iip1
+          IF( vcov(ij,l).NE.vcov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  VCOV  ---  n est pas',  
+     ,   ' periodique en longitude !'
+          PRINT *,' l,  ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l)
+          vcov(ij+iim,l)=vcov(ij,l)
+c         STOP
+          ENDIF
+         ENDDO
+      ENDDO
+      
+c
+      DO nq =1, nqmx
+        DO l =1, llm
+          DO ij = 1, ip1jmp1, iip1
+          IF( q(ij,l,nq).NE.q(ij+iim,l,nq) )  THEN
+          PRINT *,'STOP dans test_period car ---  Q  ---  n est pas ',  
+     ,   'periodique en longitude !'
+          PRINT *,' nq , l,  ij = ', nq, l, ij, ij+iim
+          STOP
+          ENDIF
+          ENDDO
+        ENDDO
+      ENDDO
+c
+       DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( p(ij,l).NE.p(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  P  ---  n est pas',  
+     ,    ' periodique en longitude !'
+          PRINT *,' l ij = ',l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( phis(ij).NE.phis(ij+iim) )  THEN
+          PRINT *,'STOP dans test_period car ---  PHIS  ---  n est pas',  
+     ,   ' periodique en longitude !  l, IJ = ', l, ij,ij+iim
+          PRINT *,' ij = ', ij, ij+iim
+          STOP
+          ENDIF
+         ENDDO
+         do ij=1,iim
+          if (p(ij,l).ne.p(1,l)
+     s     .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then
+          PRINT *,'STOP dans test_period car ---  P     ---  n est pas',  
+     ,  ' constant aux poles ! '
+          print*,'p(',1 ,',',l,')=',p(1 ,l)
+          print*,'p(',ij,',',l,')=',p(ij,l)
+          print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l)
+          print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l)
+          stop
+          endif
+         enddo
+       ENDDO
+c
+c
+         RETURN
+         END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/tetaleveli1j.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/tetaleveli1j.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/tetaleveli1j.F	(revision 984)
@@ -0,0 +1,139 @@
+c================================================================
+c================================================================
+      SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+!      USE dimphy
+      IMPLICIT none
+
+#include "dimensions.h"
+ccccc#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cIM 211004
+c     INTEGER lt(klon), lb(klon)
+c     REAL ptop, pbot, aist(klon), aisb(klon)
+c
+#include "paramet.h"
+c
+      INTEGER lt(ip1jm), lb(ip1jm)
+      REAL ptop, pbot, aist(ip1jm), aisb(ip1jm)
+cMI 211004
+      save lt,lb,ptop,pbot,aist,aisb
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+c=====================================================================
+      if (lnew) then
+c   on réinitialise les réindicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Frédéric Hourdin (3/01/02)
+
+        IF(pgcm(i,lb(i)).EQ.0.OR.
+     $     pgcm(i,lt(i)).EQ.0.) THEN
+c
+        PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+     .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        ENDIF 
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/tetaleveli1j1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/tetaleveli1j1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/tetaleveli1j1.F	(revision 984)
@@ -0,0 +1,139 @@
+c================================================================
+c================================================================
+      SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+!      USE dimphy
+      IMPLICIT none
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cIM 211004
+c     INTEGER lt(klon), lb(klon)
+c     REAL ptop, pbot, aist(klon), aisb(klon)
+c
+#include "paramet.h"
+c
+      INTEGER lt(ip1jmp1), lb(ip1jmp1)
+      REAL ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1)
+cMI 211004
+      save lt,lb,ptop,pbot,aist,aisb
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+c=====================================================================
+      if (lnew) then
+c   on réinitialise les réindicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Frédéric Hourdin (3/01/02)
+
+        IF(pgcm(i,lb(i)).EQ.0.OR.
+     $     pgcm(i,lt(i)).EQ.0.) THEN
+c
+        PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+     .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        ENDIF 
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/tourabs.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/tourabs.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/tourabs.F	(revision 984)
@@ -0,0 +1,98 @@
+      SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Modif:  I. Musat (28/10/04)
+c   -------
+c   adaptation du code tourpot.F pour le calcul de la vorticite absolue
+c   cf. P. Le Van
+c
+c   Objet: 
+c   ------
+c
+c    *******************************************************************
+c    .............  calcul de la vorticite absolue     .................
+c    *******************************************************************
+c
+c     ntetaSTD, vcov,ucov      sont des argum. d'entree pour le s-pg .
+c             vorabs            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "comconst.h"
+c
+      INTEGER ntetaSTD
+      REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD )
+      REAL vorabs( ip1jm,ntetaSTD )
+c
+c variables locales
+      INTEGER l, ij, i, j
+      REAL  rot( ip1jm,ntetaSTD )
+
+
+
+c  ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,ntetaSTD
+
+      DO 2 i = 1, iip1
+      DO 2 j = 1, jjm
+c
+       ij=i+(j-1)*iip1
+       IF(ij.LE.ip1jm - 1) THEN
+c
+        IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR.
+     $     cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN
+         rot( ij,l ) = 0.
+         continue
+        ELSE
+         rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/
+     $                 (2.*pi*RAD*cos(rlatv(j)))*float(iim)
+     $                +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/
+     $                 (pi*RAD)*(float(jjm)-1.)
+c
+        ENDIF
+       ENDIF !(ij.LE.ip1jm - 1) THEN
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, ntetaSTD
+
+      DO 6 ij = 1, ip1jm - 1
+      vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) )
+   6  CONTINUE
+
+c    ..... correction pour  vorabs( iip1,j,l)  .....
+c    ....   vorabs(iip1,j,l)= vorabs(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorabs( ij,l ) = vorabs( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/tourpot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/tourpot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/tourpot.F	(revision 984)
@@ -0,0 +1,81 @@
+!
+! $Header$
+!
+      SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ip1jm,llm )
+      REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm )
+      REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm )
+
+      INTEGER l, ij
+
+
+
+
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,llm
+
+      DO 2 ij = 1, ip1jm - 1
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, llm
+
+      DO 6 ij = 1, ip1jm - 1
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/traceurpole.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/traceurpole.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/traceurpole.F	(revision 984)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+          subroutine traceurpole(q,masse)
+
+          implicit none
+      
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+
+c   Arguments
+       integer iq
+       real masse(iip1,jjp1,llm)
+       real q(iip1,jjp1,llm)
+       
+
+c   Locals
+      integer i,j,l
+      real sommemassen(llm)
+      real sommemqn(llm)
+      real sommemasses(llm)
+      real sommemqs(llm)
+      real qpolen(llm),qpoles(llm)
+
+    
+c On impose une seule valeur au pôle Sud j=jjm+1=jjp1       
+      sommemasses=0
+      sommemqs=0
+          do l=1,llm
+             do i=1,iip1          
+                 sommemasses(l)=sommemasses(l)+masse(i,jjp1,l)
+                 sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l)
+             enddo         
+          qpoles(l)=sommemqs(l)/sommemasses(l)
+          enddo
+
+c On impose une seule valeur du traceur au pôle Nord j=1
+      sommemassen=0
+      sommemqn=0  
+         do l=1,llm
+           do i=1,iip1              
+               sommemassen(l)=sommemassen(l)+masse(i,1,l)
+               sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l)
+           enddo
+           qpolen(l)=sommemqn(l)/sommemassen(l) 
+         enddo
+    
+c On force le traceur à prendre cette valeur aux pôles
+        do l=1,llm
+            do i=1,iip1
+               q(i,1,l)=qpolen(l)
+               q(i,jjp1,l)=qpoles(l)
+             enddo
+        enddo
+
+      
+      return
+      end           
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/tracstoke.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/tracstoke.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/tracstoke.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/ugeostr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/ugeostr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/ugeostr.F	(revision 984)
@@ -0,0 +1,67 @@
+!
+! $Header$
+!
+      subroutine ugeostr(phi,ucov)
+
+
+c  Calcul du vent covariant geostrophique a partir du champs de
+c  geopotentiel en supposant que le vent au sol est nul.
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+      real um(jjm,llm),fact,u(iip1,jjm,llm)
+      integer i,j,l
+
+      real zlat
+
+      DO j=1,jjm
+
+         if (abs(sin(rlatv(j))).lt.1.e-4) then
+             zlat=1.e-4
+         else
+             zlat=rlatv(j)
+         endif
+         fact=cos(zlat)
+         fact=fact*fact
+         fact=fact*fact
+         fact=fact*fact
+         fact=(1.-fact)/
+     s    (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j)))
+         fact=-fact/rad
+         DO l=1,llm
+            DO i=1,iim
+               u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
+               um(j,l)=um(j,l)+u(i,j,l)/float(iim)
+            ENDDO
+         ENDDO
+      ENDDO
+      call dump2d(jjp1,llm,um,'Vent-u geostrophique')
+
+c
+c-----------------------------------------------------------------------
+c   calcul des champ de vent:
+c   -------------------------
+
+      DO 301 l=1,llm
+         DO 302 i=1,iip1
+            ucov(i,1,l)=0.
+            ucov(i,jjp1,l)=0.
+302      CONTINUE
+         DO 304 j=2,jjm
+            DO 305 i=1,iim
+               ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j)
+305         CONTINUE
+            ucov(iip1,j,l)=ucov(1,j,l)
+304      CONTINUE
+301   CONTINUE
+
+      print*,301
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/vitvert.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/vitvert.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/vitvert.F	(revision 984)
@@ -0,0 +1,52 @@
+!
+! $Header$
+!
+      SUBROUTINE vitvert ( convm , w )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ip1jmp1,llm),convm(ip1jmp1,llm)
+      INTEGER   l, ij
+
+
+
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = 1,ip1jmp1
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+
+      DO 5 ij  = 1,ip1jmp1
+      w(ij,1)  = 0.
+5     CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/vlsplt.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/vlsplt.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/vlsplt.F	(revision 984)
@@ -0,0 +1,959 @@
+!
+! $Header$
+!
+c
+c
+
+      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pente_max facteur de limitation des pentes: 2 en general
+c                                               0 pour un schema amont
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+c      REAL masse(iip1,jjp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+c      REAL q(iip1,jjp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      INTEGER ijlqmin,iqmin,jqmin,lqmin
+c
+      REAL zm(ip1jmp1,llm),newmasse
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm),zz
+      REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
+      REAL second,temps0,temps1,temps2,temps3
+      REAL ztemps1,ztemps2,ztemps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+      INTEGER iminn,imaxx
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+      
+      CALL SCOPY(ijp1llm,q,1,zq,1)
+      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+cprint*,'Entree vlx1'
+c	call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call vlx(zq,pente_max,zm,mu)
+cprint*,'Sortie vlx1'
+c	call minmaxq(zq,qmin,qmax,'apres vlx1    ')
+
+c print*,'Entree vly1'
+      call vly(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly1     ')
+cprint*,'Sortie vly1'
+      call vlz(zq,pente_max,zm,mw)
+c	call minmaxq(zq,qmin,qmax,'apres vlz     ')
+
+
+      call vly(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly     ')
+
+
+      call vlx(zq,pente_max,zm,mu)
+c	call minmaxq(zq,qmin,qmax,'apres vlx2    ')
+	
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlx(q,pente_max,masse,u_m)
+
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical extremum,first,testcpu
+      SAVE first,testcpu
+
+      REAL      SSUM
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+
+      REAL z1,z2,z3
+
+      DATA first,testcpu/.true.,.false./
+
+      IF(first) THEN
+         temps1=0.
+         temps2=0.
+         temps3=0.
+         temps4=0.
+         temps5=0.
+         first=.false.
+      ENDIF
+
+c   calcul de la pente a droite et a gauche de la maille
+
+
+      IF (pente_max.gt.-1.e-5) THEN
+c       IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+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)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=iip2,ip1jm
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=iip2+1,ip1jm
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+cprint*,'Ok calcul des pentes'
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+
+      DO l=1,llm
+         DO ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+         DO ij=1,ip1jmp1
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+
+c print*,'Bouclage en iip1'
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+
+      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),
+     ,                     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),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+cprint*,'Cumule ....'
+
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+c	print*,'masse(',ij,')=',masse(ij,l)
+          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))
+          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))
+          ENDIF
+       ENDDO
+      ENDDO
+#endif
+c	stop
+
+c	go to 9999
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+      DO l=1,llm
+         DO ij=iip2,ip1jm-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+cprint*,'Ok test 1'
+      DO l=1,llm
+       DO ij=iip1+iip1,ip1jm,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c print*,'Ok test 2'
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+      DO l=1,llm
+         nl(l)=0
+         DO ij=iip2,ip1jm
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+
+      IF(n0.gt.0) THEN
+      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+     &       ,'contenu de la maille : ',n0
+
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=iip2,ip1jm
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     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)
+                        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))
+                  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)
+                        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))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF  ! n0.gt.0 
+9999    continue
+
+
+c   bouclage en latitude
+cprint*,'cvant bouclage en latitude'
+      DO l=1,llm
+        DO ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+
+
+c   calcul des tENDances
+
+      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)+
+     &      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)
+         DO ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+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)
+
+
+      RETURN
+      END
+      SUBROUTINE vly(q,pente_max,masse,masse_adv_v)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical extremum,first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE first,testcpu
+
+      REAL convpn,convps,convmpn,convmps
+      real massepn,masseps,qpn,qps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c
+c
+      REAL      SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+cPRINT*,'CALCUL EN LATITUDE'
+
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      DO ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      DO ij=iip2,ip1jm
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+
+      DO ij=1,iip1
+         dyq(ij,l)=qpns-q(ij+iip1,l)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+      ENDDO
+
+c   filtrage de la derivee
+      dyn1=0.
+      dys1=0.
+      dyn2=0.
+      dys2=0.
+      DO ij=1,iim
+         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+      ENDDO
+
+c   calcul des pentes limites aux poles
+
+      goto 8888
+      fn=1.
+      fs=1.
+      DO ij=1,iim
+         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+         ENDIF
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+      ENDDO
+8888    continue
+      DO ij=1,iip1
+         dyq(ij,l)=0.
+         dyq(ip1jm+ij,l)=0.
+      ENDDO
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+
+      DO ij=iip2,ip1jm
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+
+      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))
+          ELSE
+              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+          ENDIF
+          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+
+
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+            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
+c.-. ancienne version
+c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+
+         convpn=SSUM(iim,qbyv(1,l),1)
+         convmpn=ssum(iim,masse_adv_v(1,l),1)
+         massepn=ssum(iim,masse(1,l),1)
+         qpn=0.
+         do ij=1,iim
+            qpn=qpn+masse(ij,l)*q(ij,l)
+         enddo
+         qpn=(qpn+convpn)/(massepn+convmpn)
+         do ij=1,iip1
+            q(ij,l)=qpn
+         enddo
+
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+
+         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)
+         qps=0.
+         do ij = ip1jm+1,ip1jmp1-1
+            qps=qps+masse(ij,l)*q(ij,l)
+         enddo
+         qps=(qps+convps)/(masseps+convmps)
+         do ij=ip1jm+1,ip1jmp1
+            q(ij,l)=qps
+         enddo
+
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*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        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*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        ENDDO
+c._. fin nouvelle version
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlz(q,pente_max,masse,w)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL wq(ip1jmp1,llm+1),newmasse
+
+      REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
+      REAL sigw
+
+      LOGICAL testcpu
+      SAVE testcpu
+
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      REAL      SSUM
+
+      DATA testcpu/.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps0=second(0.)
+      ENDIF
+#endif
+      DO l=2,llm
+         DO ij=1,ip1jmp1
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         ENDDO
+      ENDDO
+
+      DO l=2,llm-1
+         DO ij=1,ip1jmp1
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            ELSE
+                dzq(ij,l)=0.
+            ENDIF
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      ENDDO
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps1=temps1+second(0.)-temps0
+      ENDIF
+#endif
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+       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))
+          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))
+          ENDIF
+         ENDDO
+       ENDDO
+
+       DO ij=1,ip1jmp1
+          wq(ij,llm+1)=0.
+          wq(ij,1)=0.
+       ENDDO
+
+      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)=newmasse
+         ENDDO
+      ENDDO
+
+
+      RETURN
+      END
+c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
+c
+c#include "dimensions.h"
+c#include "paramet.h"
+
+c      CHARACTER*(*) comment
+c      real qmin,qmax
+c      real zq(ip1jmp1,llm)
+
+c      INTEGER jadrs(ip1jmp1), jbad, k, i
+
+
+c      DO k = 1, llm
+c         jbad = 0
+c         DO i = 1, ip1jmp1
+c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+c            jbad = jbad + 1
+c            jadrs(jbad) = i
+c         ENDIF
+c         ENDDO
+c         IF (jbad.GT.0) THEN
+c         PRINT*, comment
+c         DO i = 1, jbad
+cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
+c         ENDDO
+c         ENDIF
+c      ENDDO
+
+c      return
+c      end
+      subroutine minmaxq(zq,qmin,qmax,comment)
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      character*20 comment
+      real qmin,qmax
+      real zq(ip1jmp1,llm)
+      real zzq(iip1,jjp1,llm)
+
+      integer imin,jmin,lmin,ijlmin
+      integer imax,jmax,lmax,ijlmax
+
+      integer ismin,ismax
+
+#ifdef isminismax
+      call scopy (ip1jmp1*llm,zq,1,zzq,1)
+
+      ijlmin=ismin(ijp1llm,zq,1)
+      lmin=(ijlmin-1)/ip1jmp1+1
+      ijlmin=ijlmin-(lmin-1.)*ip1jmp1
+      jmin=(ijlmin-1)/iip1+1
+      imin=ijlmin-(jmin-1.)*iip1
+      zqmin=zq(ijlmin,lmin)
+
+      ijlmax=ismax(ijp1llm,zq,1)
+      lmax=(ijlmax-1)/ip1jmp1+1
+      ijlmax=ijlmax-(lmax-1.)*ip1jmp1
+      jmax=(ijlmax-1)/iip1+1
+      imax=ijlmax-(jmax-1.)*iip1
+      zqmax=zq(ijlmax,lmax)
+
+       if(zqmin.lt.qmin) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
+       if(zqmax.gt.qmax) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
+
+#endif
+      return
+9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
+      end
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/vlspltqs.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/vlspltqs.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/vlspltqs.F	(revision 984)
@@ -0,0 +1,775 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
+     ,                                  p,pk,teta                 )
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
+c
+c    ********************************************************************
+c          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL qsat(ip1jmp1,llm)
+      REAL zm(ip1jmp1,llm)
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm)
+      REAL temps1,temps2,temps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+      REAL tempe(ip1jmp1)
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c-- Calcul de Qsat en chaque point
+c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+c   pour eviter une exponentielle.
+        DO l = 1, llm
+         DO ij = 1, ip1jmp1
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = 1, ip1jmp1
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+
+      CALL SCOPY(ijp1llm,q,1,zq,1)
+      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
+      call vlxqs(zq,pente_max,zm,mu,qsat)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
+
+      call vlyqs(zq,pente_max,zm,mv,qsat)
+
+
+c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
+
+      call vlz(zq,pente_max,zm,mw)
+
+
+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)
+
+
+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)
+
+c     call minmaxq(zq,qmin,qmax,'apres vlxqs     ')
+c     call minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
+
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm )
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical first,testcpu
+      SAVE first,testcpu
+
+      REAL      SSUM
+      REAL temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+
+
+      DATA first,testcpu/.true.,.false./
+
+      IF(first) THEN
+         temps1=0.
+         temps2=0.
+         temps3=0.
+         temps4=0.
+         temps5=0.
+         first=.false.
+      ENDIF
+
+c   calcul de la pente a droite et a gauche de la maille
+
+
+      IF (pente_max.gt.-1.e-5) THEN
+c     IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+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)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=iip2,ip1jm
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=iip2+1,ip1jm
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+
+      DO l=1,llm
+         DO ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+
+         DO ij=1,ip1jmp1
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c--pas encore modification sur Qsat
+      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),
+     ,                     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),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+#else
+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)
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          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)*
+     $         min(q(ij,l)+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)
+             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))
+          ENDIF
+       ENDDO
+      ENDDO
+#endif
+
+
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+      DO l=1,llm
+         DO ij=iip2,ip1jm-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+      DO l=1,llm
+       DO ij=iip1+iip1,ip1jm,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c   pas d'influence de la pression saturante (pour l'instant)
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+      DO l=1,llm
+         nl(l)=0
+         DO ij=iip2,ip1jm
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+
+      IF(n0.gt.0) THEN
+ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+ccc     &       ,'contenu de la maille : ',n0
+
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=iip2,ip1jm
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     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)
+                        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))
+                  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)
+                        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))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF  ! n0.gt.0 
+
+
+
+c   bouclage en latitude
+
+      DO l=1,llm
+        DO ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+
+
+c   calcul des tendances
+
+      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)+
+     &      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)
+         DO ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+
+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)
+
+
+      RETURN
+      END
+      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     qsat 	       est   un argument de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE first,testcpu
+
+      REAL convpn,convps,convmpn,convmps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c
+c
+      REAL      SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+
+
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      DO ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      DO ij=iip2,ip1jm
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+
+      DO ij=1,iip1
+         dyq(ij,l)=qpns-q(ij+iip1,l)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+      ENDDO
+
+c   filtrage de la derivee
+      dyn1=0.
+      dys1=0.
+      dyn2=0.
+      dys2=0.
+      DO ij=1,iim
+         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+      ENDDO
+
+c   calcul des pentes limites aux poles
+
+      fn=1.
+      fs=1.
+      DO ij=1,iim
+         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+         ENDIF
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+      ENDDO
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+
+      DO ij=iip2,ip1jm
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+
+      DO l=1,llm
+       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)))
+         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)) )
+         ENDIF
+          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+
+
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+            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
+c.-. ancienne version
+         convpn=SSUM(iim,qbyv(1,l),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)=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)=newmasse
+         ENDDO
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*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        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*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        ENDDO
+c._. fin nouvelle version
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/wrgrads.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/wrgrads.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/wrgrads.F	(revision 984)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+      subroutine wrgrads(if,nl,field,name,titlevar)
+      implicit none
+
+c   Declarations
+c    if indice du fichier
+c    nl nombre de couches
+c    field   champ
+c    name    petit nom
+c    titlevar   Titre
+
+#include "gradsdef.h"
+
+c   arguments
+      integer if,nl
+      real field(imx*jmx*lmx)
+      character*10 name,file
+      character*10 titlevar
+
+c   local
+
+      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
+
+      logical writectl
+
+
+      writectl=.false.
+
+c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
+      iii=iid(if)
+      iji=jid(if)
+      iif=ifd(if)
+      ijf=jfd(if)
+      im=iif-iii+1
+      jm=ijf-iji+1
+      lm=lmd(if)
+
+c     print*,'im,jm,lm,name,firsttime(if)'
+c     print*,im,jm,lm,name,firsttime(if)
+
+      if(firsttime(if)) then
+         if(name.eq.var(1,if)) then
+            firsttime(if)=.false.
+            ivar(if)=1
+         print*,'fin de l initialiation de l ecriture du fichier'
+         print*,file
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+         else
+            ivar(if)=ivar(if)+1
+            nvar(if)=ivar(if)
+            var(ivar(if),if)=name
+            tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
+            nld(ivar(if),if)=nl
+c           print*,'initialisation ecriture de ',var(ivar(if),if)
+c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      do l=1,nl
+         irec(if)=irec(if)+1
+c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+         write(unit(if)+1,rec=irec(if))
+     s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
+     s   ,i=iii,iif),j=iji,ijf)
+      enddo
+      if (writectl) then
+
+      file=fichier(if)
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      open(unit(if),file=file(1:lnblnk(file))//'.ctl'
+     &         ,form='formatted',status='unknown')
+      write(unit(if),'(a5,1x,a40)')
+     &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
+
+      write(unit(if),'(a12)') 'UNDEF 1.0E30'
+      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+      write(unit(if),'(a4,i10,a30)')
+     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+      do iv=1,nvar(if)
+c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
+     &     ,99,tvar(iv,if)
+      enddo
+      write(unit(if),'(a7)') 'ENDVARS'
+c
+1000  format(a5,3x,i4,i3,1x,a39)
+
+      close(unit(if))
+
+      endif ! writectl
+
+      return
+
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/write_grads_dyn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/write_grads_dyn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/write_grads_dyn.h	(revision 984)
@@ -0,0 +1,31 @@
+!
+! $Header$
+!
+      if (callinigrads) then
+
+         string10='dyn'
+         call inigrads(1,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtvr*iperiod,string10,'dyn_zon ')
+
+        callinigrads=.false.
+
+
+      endif
+
+      string10='ps'
+      CALL wrgrads(1,1,ps,string10,string10)
+
+      string10='u'
+      CALL wrgrads(1,llm,unat,string10,string10)
+      string10='v'
+      CALL wrgrads(1,llm,vnat,string10,string10)
+      string10='teta'
+      CALL wrgrads(1,llm,teta,string10,string10)
+      do iq=1,nqmx
+         string10='q'
+         write(string10(2:2),'(i1)') iq
+         CALL wrgrads(1,llm,q(:,:,iq),string10,string10)
+      enddo
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3d/write_paramLMDZ_dyn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3d/write_paramLMDZ_dyn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3d/write_paramLMDZ_dyn.h	(revision 984)
@@ -0,0 +1,243 @@
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Attention : il n'y a aucune raison pour ecrire ces constantes
+! comme des champs 2D. A corriger un jour ...
+
+c
+      ndex2d = 0
+      itau_w=itau_dyn+itau
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(prt_level) 
+      CALL histwrite(nid_ctesGCM, "prt_level", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(dayref)
+      CALL histwrite(nid_ctesGCM, "dayref", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(anneeref)
+      CALL histwrite(nid_ctesGCM, "anneeref", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(raz_date)
+      CALL histwrite(nid_ctesGCM, "raz_date", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nday)
+      CALL histwrite(nid_ctesGCM, "nday", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(day_step)
+      CALL histwrite(nid_ctesGCM, "day_step", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iperiod)
+      CALL histwrite(nid_ctesGCM, "iperiod", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iapp_tracvl)
+      CALL histwrite(nid_ctesGCM, "iapp_tracvl", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iconser)
+      CALL histwrite(nid_ctesGCM, "iconser", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iecri)
+      CALL histwrite(nid_ctesGCM, "iecri", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=periodav
+      CALL histwrite(nid_ctesGCM, "periodav", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(idissip)
+      CALL histwrite(nid_ctesGCM, "idissip", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(lstardis) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "lstardis", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nitergdiv)
+      CALL histwrite(nid_ctesGCM, "nitergdiv", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(nitergrot)
+      CALL histwrite(nid_ctesGCM, "nitergrot", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(niterh) 
+      CALL histwrite(nid_ctesGCM, "niterh", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tetagdiv
+      CALL histwrite(nid_ctesGCM, "tetagdiv", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tetagrot
+      CALL histwrite(nid_ctesGCM, "tetagrot", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tetatemp
+      CALL histwrite(nid_ctesGCM, "tetatemp", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=coefdis
+      CALL histwrite(nid_ctesGCM, "coefdis", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(purmats) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "purmats", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(ok_guide) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "ok_guide", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(true_calendar) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "true_calendar", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iflag_phys)
+      CALL histwrite(nid_ctesGCM, "iflag_phys", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=FLOAT(iphysiq)
+      CALL histwrite(nid_ctesGCM, "iphysiq", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02
+! La variable cycle_diurne n'est pas vue par la dynamique
+!     IF(cycle_diurne) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "cycle_diurne", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(soil_model) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "soil_model", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(new_oliq) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "new_oliq", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(ok_orodr) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "ok_orodr", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(ok_orolf) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "ok_orolf", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     IF(ok_limitvrai) THEN
+!      zx_tmp_2d(1:iip1,1:jjp1)=1.
+!     ELSE
+!      zx_tmp_2d(1:iip1,1:jjp1)=0.
+!     ENDIF
+!     CALL histwrite(nid_ctesGCM, "ok_limitvrai", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     zx_tmp_2d(1:iip1,1:jjp1)=nbapp_rad
+!     CALL histwrite(nid_ctesGCM, "nbapp_rad", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!
+!     zx_tmp_2d(1:iip1,1:jjp1)=iflag_con
+!     CALL histwrite(nid_ctesGCM, "iflag_con", itau_w,
+!    .               zx_tmp_2d,iip1*jjp1,ndex2d)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=clon
+      CALL histwrite(nid_ctesGCM, "clon", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=clat
+      CALL histwrite(nid_ctesGCM, "clat", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=grossismx
+      CALL histwrite(nid_ctesGCM, "grossismx", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=grossismy
+      CALL histwrite(nid_ctesGCM, "grossismy", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(fxyhypb) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "fxyhypb", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=dzoomx
+      CALL histwrite(nid_ctesGCM, "dzoomx", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=dzoomy
+      CALL histwrite(nid_ctesGCM, "dzoomy", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=taux
+      CALL histwrite(nid_ctesGCM, "taux", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=tauy
+      CALL histwrite(nid_ctesGCM, "tauy", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      IF(ysinus) THEN
+       zx_tmp_2d(1:iip1,1:jjp1)=1.
+      ELSE
+       zx_tmp_2d(1:iip1,1:jjp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM, "ysinus", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+      zx_tmp_2d(1:iip1,1:jjp1)=ip_ebil_dyn
+      CALL histwrite(nid_ctesGCM, "ip_ebil_dyn", itau_w,
+     .               zx_tmp_2d,iip1*jjp1,ndex2d)
+c
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_ctesGCM)
+      endif
+c
+c=================================================================
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/PVtheta.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/PVtheta.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/PVtheta.F	(revision 984)
@@ -0,0 +1,196 @@
+      SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta,
+     $           ztfi,zplay,zplev,
+     $           nbteta,theta,PVteta)
+      IMPLICIT none
+
+c=======================================================================
+c
+c   Auteur:  I. Musat
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    Calcul de la vorticite potentielle PVteta sur des iso-theta selon
+c    la methodologie du NCEP/NCAR :
+c    1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les
+c       niveaux du modele => N2
+c    2) on interpole les vents, la temperature et le N**2 sur des isentropes
+c       (en fait sur des iso-theta) lineairement en log(theta) =>
+c       ucovteta, vcovteta, N2teta
+c    3) on calcule la vorticite absolue sur des iso-theta => vorateta
+c    4) on calcule la densite rho sur des iso-theta => rhoteta 
+c
+c       rhoteta = (T/theta)**(cp/R)*p0/(R*T)
+c
+c    5) on calcule la vorticite potentielle sur des iso-theta => PVteta
+c
+c       PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU
+c
+c       NB: 1PVU=10**(-6) K*m**2/(s * kg)
+c
+c       PVteta =  vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s)
+c
+c
+c    *******************************************************************
+c
+c
+c     Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta
+c                       -> sur la grille dynamique
+c     Variable de sortie : PVteta
+c                       -> sur la grille physique 
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+c
+c variables Input
+c
+      INTEGER ilon, ilev
+      REAL pvcov(iip1,jjm,ilev)
+      REAL pucov(iip1,jjp1,ilev)
+      REAL pteta(iip1,jjp1,ilev)
+      REAL ztfi(ilon,ilev)
+      REAL zplay(ilon,ilev), zplev(ilon,ilev+1)
+      INTEGER nbteta
+      REAL theta(nbteta)
+c
+c variable Output
+c
+      REAL PVteta(ilon,nbteta)
+c
+c variables locales
+c
+      INTEGER i, j, l, ig0
+      REAL SSUM
+      REAL teta(ilon, ilev)
+      REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev)
+      REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev)
+      REAL N2(ilon,ilev-1), N2teta(ilon,nbteta)
+      REAL ztfiteta(ilon,nbteta)
+      REAL rhoteta(ilon,nbteta)
+      REAL vorateta(iip1,jjm,nbteta)
+      REAL voratetafi(ilon,nbteta), vorpol(iim)
+c
+#include "comgeom2.h"
+#include "comconst.h"
+#include "comvert.h"
+c
+c projection teta sur la grille physique
+c
+      DO l=1,llm
+       teta(1,l)   =  pteta(1,1,l)
+       ig0         = 2
+       DO j = 2, jjm
+        DO i = 1, iim
+         teta(ig0,l)    = pteta(i,j,l)
+         ig0            = ig0 + 1
+        ENDDO
+       ENDDO
+       teta(ig0,l)    = pteta(1,jjp1,l)
+      ENDDO
+c
+c calcul pteta sur les grilles U et V
+c
+      DO l=1, llm
+       DO j=1, jjp1
+        DO i=1, iip1
+         ig0=i+(j-1)*iip1
+         ptetau(ig0,l)=pteta(i,j,l)
+        ENDDO !i
+       ENDDO !j
+       DO j=1, jjm
+        DO i=1, iip1
+         ig0=i+(j-1)*iip1
+         ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l))
+        ENDDO !i
+       ENDDO !j
+      ENDDO !l
+c
+c projection pucov, pvcov sur une surface de theta constante
+c
+      DO l=1, nbteta
+cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l),
+       CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l),
+     .                pucov,ucovteta(:,l))
+cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l),
+       CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l),
+     .                pvcov,vcovteta(:,l))
+      ENDDO !l
+c
+c calcul vorticite absolue sur une iso-theta : vorateta
+c
+      CALL tourabs(nbteta,vcovteta,ucovteta,vorateta)
+c
+c projection vorateta sur la grille physique => voratetafi
+c
+      DO l=1,nbteta
+       DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+         voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) +
+     $                           vorateta(i+1,j-1,l) * alpha1(i+1,j) +
+     $                           vorateta(i  ,j  ,l) * alpha3(i+1,j) +
+     $                           vorateta(i+1,j  ,l) * alpha2(i+1,j)
+        ENDDO
+        voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l)
+       ENDDO
+      ENDDO
+c
+      DO l=1,nbteta
+       DO i=1,iim
+        vorpol(i)  = vorateta(i,1,l)*aire(i,1)
+       ENDDO
+       voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln
+      ENDDO
+c
+      DO l=1,nbteta
+       DO i=1,iim
+        vorpol(i)  = vorateta(i,jjm,l)* aire(i,jjm +1)
+       ENDDO
+       voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols
+      ENDDO
+c 
+c calcul N**2 sur la grille physique => N2
+c
+      DO l=1, llm-1 
+       DO i=1, ilon
+        N2(i,l) = (g**2 * zplay(i,l) * 
+     $            (ztfi(i,l+1)-ztfi(i,l)) )/
+     $            (R*ztfi(i,l)*ztfi(i,l)*
+     $            (zplev(i,l)-zplev(i,l+1)) )+
+     $            (g**2)/(ztfi(i,l)*CPP)
+       ENDDO !i
+      ENDDO !l
+c
+c calcul N2 sur une iso-theta => N2teta 
+c
+      DO l=1, nbteta
+       CALL tetalevel(ilon,llm-1,.true.,teta,theta(l),
+     $                N2,N2teta(:,l))
+       CALL tetalevel(ilon,llm,.true.,teta,theta(l),
+     $                ztfi,ztfiteta(:,l))
+      ENDDO !l=1, nbteta
+c
+c calcul rho et PV sur une iso-theta : rhoteta, PVteta
+c
+      DO l=1, nbteta
+       DO i=1, ilon
+        rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)*
+     $  (preff/(R*ztfiteta(i,l)))
+c
+c PVteta en PVU
+c
+        PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/
+     $              (g**2*rhoteta(i,l))
+c
+c PVteta en 1/(Pa*s)
+c
+        PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/
+     $              (g**2*rhoteta(i,l))
+       ENDDO !i
+      ENDDO !l
+c
+      RETURN
+      END 
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/abort_gcm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/abort_gcm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/abort_gcm.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+#include "iniprint.h"
+ 
+C
+C Stops the simulation cleanly, closing files and printing various
+C comments
+C
+C  Input: modname = name of calling program
+C         message = stuff to print
+C         ierr    = severity of situation ( = 0 normal )
+
+      character (len=20) :: modname
+      integer ierr
+      character (len=80) :: message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+      call histclo
+      call restclo
+#endif
+c     call getin_dump
+c     call histclo(2)
+c     call histclo(3)
+c     call histclo(4)
+c     call histclo(5)
+      write(lunout,*) 'Stopping in ', modname
+      write(lunout,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+      endif
+      STOP
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/academic.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/academic.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/academic.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      real tetarappel(ip1jmp1,llm),taurappel
+      common/academic/tetarappel,taurappel
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/adaptdt.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/adaptdt.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/adaptdt.F	(revision 984)
@@ -0,0 +1,59 @@
+!
+! $Header$
+!
+      subroutine adaptdt(nadv,dtbon,n,pbaru,
+     c                   masse)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+c----------------------------------------------------------
+c     Arguments
+c----------------------------------------------------------
+      INTEGER n,nadv
+      REAL dtbon 
+      REAL pbaru(iip1,jjp1,llm)
+      REAL masse(iip1,jjp1,llm)
+c----------------------------------------------------------    
+c     Local
+c----------------------------------------------------------
+      INTEGER i,j,l
+      REAL CFLmax,aaa,bbb
+      
+        CFLmax=0.
+        do l=1,llm
+         do j=2,jjm
+          do i=1,iim
+             aaa=pbaru(i,j,l)*dtvr/masse(i,j,l)
+             CFLmax=max(CFLmax,aaa)
+             bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l)
+             CFLmax=max(CFLmax,bbb)
+          enddo
+         enddo
+        enddo              
+        n=int(CFLmax)+1
+c pour reproduire cas VL du code qui appele x,y,z,y,x
+c        if (nadv.eq.30) n=n/2   ! Pour Prather
+        dtbon=dtvr/n
+        
+       return
+       end
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/addfi_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/addfi_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/addfi_p.F	(revision 984)
@@ -0,0 +1,245 @@
+!
+! $Header$
+!
+      SUBROUTINE addfi_p(nq, pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      USE parallel
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c    Addition of the physical tendencies
+c
+c    Interface :
+c    -----------
+c
+c      Input :
+c      -------
+c      pdt                    time step of integration
+c      leapf                  logical
+c      forward                logical
+c      pucov(ip1jmp1,llm)     first component of the covariant velocity
+c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+c      pteta(ip1jmp1,llm)     potential temperature
+c      pts(ip1jmp1,llm)       surface temperature
+c      pdufi(ip1jmp1,llm)     |
+c      pdvfi(ip1jm,llm)       |   respective
+c      pdhfi(ip1jmp1)         |      tendencies
+c      pdtsfi(ip1jmp1)        |
+c
+c      Output :
+c      --------
+c      pucov
+c      pvcov
+c      ph
+c      pts
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      INTEGER nq
+
+      REAL pdt
+c
+      REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
+      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)
+c
+      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
+      REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
+c
+      LOGICAL leapf,forward
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      PARAMETER ( qtestt = 1.0e-40 )
+
+      REAL SSUM
+      EXTERNAL SSUM
+      
+      INTEGER :: ijb,ije
+c
+c-----------------------------------------------------------------------
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO k = 1,llm
+         DO j = ijb,ije
+            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      if (pole_nord) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  k    = 1, llm
+         DO  ij   = 1, iim
+           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+         ENDDO
+         tpn      = SSUM(iim,xpn,1)/ apoln
+
+         DO ij   = 1, iip1
+           pteta(   ij   ,k)  = tpn
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+      endif
+
+      if (pole_sud) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  k    = 1, llm
+         DO  ij   = 1, iim
+           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+         ENDDO
+         tps      = SSUM(iim,xps,1)/ apols
+
+         DO ij   = 1, iip1
+           pteta(ij+ip1jm,k)  = tps
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+      endif
+c
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO k = 1,llm
+         DO j = ijb,ije
+            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      if (pole_nord) ijb=ij_begin
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO k = 1,llm
+         DO j = ijb,ije
+            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+      if (pole_sud)  ije=ij_end
+c$OMP MASTER
+      DO j = ijb,ije
+         pps(j) = pps(j) + pdpfi(j) * pdt
+      ENDDO
+c$OMP END MASTER
+ 
+      DO iq = 1, 2
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1,llm
+            DO j = ijb,ije
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+            ENDDO
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+
+      DO iq = 3, nq
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1,llm
+            DO j = ijb,ije
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
+            ENDDO
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+
+c$OMP MASTER
+      if (pole_nord) then
+      
+        DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pps(  ij     )
+        ENDDO
+
+        tpn      = SSUM(iim,xpn,1)/apoln
+
+        DO ij   = 1, iip1
+          pps (   ij     )  = tpn
+        ENDDO
+      
+      endif
+
+      if (pole_sud) then
+      
+        DO  ij   = 1, iim
+          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+        ENDDO
+
+        tps      = SSUM(iim,xps,1)/apols
+
+        DO ij   = 1, iip1
+          pps ( ij+ip1jm )  = tps
+        ENDDO
+      
+      endif
+c$OMP END MASTER
+
+      if (pole_nord) then
+        DO iq = 1, nq
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO  k    = 1, llm
+            DO  ij   = 1, iim
+              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+            ENDDO
+            tpn      = SSUM(iim,xpn,1)/apoln
+  
+            DO ij   = 1, iip1
+              pq (   ij   ,k,iq)  = tpn
+            ENDDO
+          ENDDO
+c$OMP END DO NOWAIT	  
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO iq = 1, nq
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO  k    = 1, llm
+            DO  ij   = 1, iim
+              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+            ENDDO
+            tps      = SSUM(iim,xps,1)/apols
+  
+            DO ij   = 1, iip1
+              pq (ij+ip1jm,k,iq)  = tps
+            ENDDO
+          ENDDO
+c$OMP END DO NOWAIT	  
+        ENDDO
+      endif
+      
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advect_new_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advect_new_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advect_new_p.F	(revision 984)
@@ -0,0 +1,284 @@
+!
+! $Header$
+!
+      SUBROUTINE advect_new_p(ucov,vcov,teta,w,massebx,masseby,
+     &                        du,dv,dteta)
+      USE parallel
+      USE write_field_p
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+      REAL,SAVE :: dv1(ip1jm,llm),du1(ip1jmp1,llm),dteta1(ip1jmp1,llm)
+      REAL,SAVE :: dv2(ip1jm,llm),du2(ip1jmp1,llm),dteta2(ip1jmp1,llm)
+c   Local:
+c   ------
+
+      REAL,SAVE :: uav(ip1jmp1,llm),vav(ip1jm,llm)
+      REAL wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l,ijb,ije
+
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+c$OMP MASTER
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+      DO ij=ijb,ije
+        du2(ij,1)=0.
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+        dv2(ij,1)=0.
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+
+      DO ij=ijb,ije
+        dteta2(ij,1)=0.
+      ENDDO
+c$OMP END MASTER
+
+ 
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)   
+      DO  l=1,llm
+         
+         ijb=ij_begin
+         ije=ij_end
+         if (pole_nord) ijb=ijb+iip1
+         if (pole_sud)  ije=ije-iip1
+         
+c         DO    ij     = iip2, ip1jmp1
+c            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+c         ENDDO
+
+c         DO    ij     = iip2, ip1jm
+c            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+c         ENDDO
+         
+         DO    ij     = ijb, ije
+                  
+           uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
+     .	             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+         ENDDO
+         
+         if (pole_nord) then
+           DO      ij         = 1, iip1
+              uav(ij      ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO      ij         = 1, iip1
+              uav(ip1jm+ij,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+c$OMP END DO      
+c      call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+      
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO  l=1,llm
+         
+         DO    ij   = ijb+1, ije
+           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         
+         DO    ij   = ijb,ije,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         
+         
+         DO    ij   = ijb, ije-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         
+         DO    ij       = ijb, ije, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+         
+      ENDDO
+c$OMP END DO
+c       call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+
+c-----------------------------------------------------------------------
+c$OMP BARRIER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if (pole_sud)  ije=ij_end
+      
+      DO 5   ij   = ijb, ije
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+         
+      DO 6 ij = ijb ,ije-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 8 ij = ijb, ije
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+        ijb=ij_begin
+        ije=ij_end
+        
+        DO 15 ij = ijb, ije
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta1(ij, l ) =   ww
+         dteta2(ij,l+1) =   ww
+  15    CONTINUE
+
+c ym ---> conser a voir plus tard
+
+c      IF( conser)  THEN
+c        
+c        DO 17 ij = 1,ip1jmp1
+c        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+c  17    CONTINUE
+c        gt       = SSUM( ip1jmp1,ge,1 )
+c        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+c      END IF
+
+  20  CONTINUE
+c$OMP END DO
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+        DO ij=ijb,ije-1
+	  du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
+	ENDDO
+
+        DO   ij   = ijb+iip1-1, ije, iip1
+         du( ij, l  ) = du( ij -iim, l  )
+        ENDDO 
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+        DO ij=ijb,ije
+	  dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
+	ENDDO
+      ENDDO
+c$OMP END DO NOWAIT      
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO l=1,llm
+        DO ij=ijb,ije
+	  dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
+	ENDDO
+      ENDDO
+c$OMP END DO NOWAIT      
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advect_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advect_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advect_p.F	(revision 984)
@@ -0,0 +1,219 @@
+!
+! $Header$
+!
+      SUBROUTINE advect_p(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
+      USE parallel
+      USE write_field_p
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l,ijb,ije
+
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+      DO  l=1,llm
+         
+         ijb=ij_begin
+         ije=ij_end
+         if (pole_nord) ijb=ijb+iip1
+         if (pole_sud)  ije=ije-iip1
+         
+c         DO    ij     = iip2, ip1jmp1
+c            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+c         ENDDO
+
+c         DO    ij     = iip2, ip1jm
+c            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+c         ENDDO
+         
+         DO    ij     = ijb, ije
+                  
+           uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l))
+     .	             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+         ENDDO
+         
+         if (pole_nord) then
+           DO      ij         = 1, iip1
+              uav(ij      ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO      ij         = 1, iip1
+              uav(ip1jm+ij,l) = 0.
+           ENDDO
+         endif
+         
+      ENDDO
+      
+c      call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+      
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO  l=1,llm
+         
+         DO    ij   = ijb+1, ije
+           vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         
+         DO    ij   = ijb,ije,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         
+         
+         DO    ij   = ijb, ije-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         
+         DO    ij       = ijb, ije, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+         
+      ENDDO
+c       call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+c-----------------------------------------------------------------------
+
+
+      
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if (pole_sud)  ije=ij_end
+      
+      DO 5   ij   = ijb, ije
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+         
+      DO 6 ij = ijb ,ije-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .....  correction pour  du(iip1,j,l)  ........
+c     .....     du(iip1,j,l)= du(1,j,l)   .....
+
+CDIR$ IVDEP
+      DO   7  ij   = ijb+iip1-1, ije, iip1
+      du( ij, l  ) = du( ij -iim, l  )
+      du( ij,l+1 ) = du( ij -iim,l+1 )
+   7  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 8 ij = ijb, ije
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+        ijb=ij_begin
+        ije=ij_end
+        
+        DO 15 ij = ijb, ije
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta(ij, l ) = dteta(ij, l )  -  ww
+         dteta(ij,l+1) = dteta(ij,l+1)  +  ww
+  15    CONTINUE
+
+c ym ---> conser a voir plus tard
+
+c      IF( conser)  THEN
+c        
+c        DO 17 ij = 1,ip1jmp1
+c        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+c  17    CONTINUE
+c        gt       = SSUM( ip1jmp1,ge,1 )
+c        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+c      END IF
+
+  20  CONTINUE
+ 
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advn.F	(revision 984)
@@ -0,0 +1,983 @@
+!
+! $Header$
+!
+      SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "iniprint.h"
+
+c
+c   Arguments:
+c   ----------
+      integer mode
+      real masse(ip1jmp1,llm)
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      integer ijlqmin,iqmin,jqmin,lqmin
+      integer ismin
+c
+      real zm(ip1jmp1,llm),newmasse
+      real mu(ip1jmp1,llm)
+      real mv(ip1jm,llm)
+      real mw(ip1jmp1,llm+1)
+      real zq(ip1jmp1,llm),zz,qpn,qps
+      real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm)
+      real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm)
+      real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm)
+      real temps0,temps1,temps2,temps3
+      real ztemps1,ztemps2,ztemps3,ssum
+      logical testcpu
+      save testcpu
+      save temps1,temps2,temps3
+      real zzpbar,zzw
+
+#ifdef CRAY
+      real second
+#endif
+
+      real qmin,qmax
+      data qmin,qmax/0.,1./
+      data testcpu/.false./
+      data temps1,temps2,temps3/0.,0.,0./
+
+      zzpbar = 0.5 * pdt
+      zzw    = pdt
+
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+
+      do l=1,llm
+         qpn=0.
+         qps=0.
+         do ij=1,iim
+            qpn=qpn+q(ij,l)*masse(ij,l)
+            qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l)
+         enddo
+         qpn=qpn/ssum(iim,masse(1,l),1)
+         qps=qps/ssum(iim,masse(ip1jm+1,l),1)
+         do ij=1,iip1
+            q(ij,l)=qpn
+            q(ip1jm+ij,l)=qps
+         enddo
+      enddo
+
+      do ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      enddo
+      do l=1,llm
+         do ij=1,ip1jmp1
+            zq(ij,l)=q(ij,l)
+            zm(ij,l)=masse(ij,l)
+         enddo
+      enddo
+
+c     call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call advnqx(zq,zqg,zqd)
+      call advnx(zq,zqg,zqd,zm,mu,mode)
+      call advnqy(zq,zqs,zqn)
+      call advny(zq,zqs,zqn,zm,mv)
+      call advnqz(zq,zqh,zqb)
+      call advnz(zq,zqh,zqb,zm,mw)
+c     call vlz(zq,0.,zm,mw)
+      call advnqy(zq,zqs,zqn)
+      call advny(zq,zqs,zqn,zm,mv)
+      call advnqx(zq,zqg,zqd)
+      call advnx(zq,zqg,zqd,zm,mu,mode)
+c     call minmaxq(zq,qmin,qmax,'apres vlx     ')
+
+#ifdef CRAY
+      if(testcpu) then
+         ztemps1=second(0.)
+         temps1=temps1+ztemps1-ztemps2
+            print*,'VLSPLT X:',temps1,'   Y:',temps2,'   Z:',temps3
+      endif
+#endif
+      do l=1,llm
+         do ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         enddo
+         do ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         enddo
+      enddo
+
+      RETURN
+      END
+
+      SUBROUTINE advnqx(q,qg,qd)
+c
+c     Auteurs:   Calcul des valeurs de q aux point u.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dxqu(ip1jmp1),zqu(ip1jmp1)
+      real zqmax(ip1jmp1),zqmin(ip1jmp1)
+      logical extremum(ip1jmp1)
+
+      integer mode
+      save mode
+      data mode/1/
+
+c   calcul des pentes en u:
+c   -----------------------
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jm
+               qd(ij,l)=q(ij,l)
+               qg(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+      do l = 1, llm
+         do ij=iip2,ip1jm-1
+            dxqu(ij)=q(ij+1,l)-q(ij,l)
+            zqu(ij)=0.5*(q(ij+1,l)+q(ij,l))
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqu(ij)=dxqu(ij-iim)
+            zqu(ij)=zqu(ij-iim)
+         enddo
+         do ij=iip2,ip1jm-1
+            zqu(ij)=zqu(ij)-dxqu(ij+1)/12.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqu(ij)=zqu(ij-iim)
+         enddo
+         do ij=iip2+1,ip1jm
+            zqu(ij)=zqu(ij)+dxqu(ij-1)/12.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqu(ij-iim)=zqu(ij)
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+
+         do ij=iip2,ip1jm-1
+            zqmax(ij)=max(q(ij+1,l),q(ij,l))
+            zqmin(ij)=min(q(ij+1,l),q(ij,l))
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            zqmax(ij)=zqmax(ij-iim)
+            zqmin(ij)=zqmin(ij-iim)
+         enddo
+         do ij=iip2+1,ip1jm
+            extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0.
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            extremum(ij-iim)=extremum(ij)
+         enddo
+         do ij=iip2,ip1jm
+            zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij))
+         enddo
+         do ij=iip2+1,ip1jm
+            if(extremum(ij)) then
+               qg(ij,l)=q(ij,l)
+               qd(ij,l)=q(ij,l)
+            else
+               qd(ij,l)=zqu(ij)
+               qg(ij,l)=zqu(ij-1)
+            endif
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            qd(ij-iim,l)=qd(ij,l)
+            qg(ij-iim,l)=qg(ij,l)
+         enddo
+
+         goto 8888
+
+         do ij=iip2+1,ip1jm
+            if(extremum(ij).and..not.extremum(ij-1))
+     s         qd(ij-1,l)=q(ij,l)
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            qd(ij-iim,l)=qd(ij,l)
+         enddo
+         do ij=iip2,ip1jm-1
+            if (extremum(ij).and..not.extremum(ij+1))
+     s         qg(ij+1,l)=q(ij,l)
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            qg(ij,l)=qg(ij-iim,l)
+         enddo
+8888     continue
+      enddo
+      endif
+      RETURN
+      END
+      SUBROUTINE advnqy(q,qs,qn)
+c
+c     Auteurs:   Calcul des valeurs de q aux point v.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dyqv(ip1jm),zqv(ip1jm,llm)
+      real zqmax(ip1jm),zqmin(ip1jm)
+      logical extremum(ip1jmp1)
+
+      integer mode
+      save mode
+      data mode/1/
+
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+               qn(ij,l)=q(ij,l)
+               qs(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+
+c   calcul des pentes en u:
+c   -----------------------
+      do l = 1, llm
+         do ij=1,ip1jm
+            dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         enddo
+
+         do ij=iip2,ip1jm-iip1
+            zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l))
+            zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12.
+         enddo
+
+         do ij=iip2,ip1jm
+            extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0.
+         enddo
+
+c Pas de pentes aux poles
+         do ij=1,iip1
+            zqv(ij,l)=q(ij,l)
+            zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l)
+            extremum(ij)=.true.
+            extremum(ip1jmp1-iip1+ij)=.true.
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+         do ij=1,ip1jm
+            zqmax(ij)=max(q(ij+iip1,l),q(ij,l))
+            zqmin(ij)=min(q(ij+iip1,l),q(ij,l))
+         enddo
+
+         do ij=1,ip1jm
+            zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij))
+         enddo
+
+         do ij=iip2,ip1jm
+            if(extremum(ij)) then
+               qs(ij,l)=q(ij,l)
+               qn(ij,l)=q(ij,l)
+c              if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l)
+c              if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l)
+            else
+               qs(ij,l)=zqv(ij,l)
+               qn(ij,l)=zqv(ij-iip1,l)
+            endif
+         enddo
+
+         do ij=1,iip1
+            qs(ij,l)=q(ij,l)
+            qn(ij,l)=q(ij,l)
+            qs(ip1jm+ij,l)=q(ip1jm+ij,l)
+            qn(ip1jm+ij,l)=q(ip1jm+ij,l)
+         enddo
+
+      enddo
+      endif
+      RETURN
+      END
+
+      SUBROUTINE advnqz(q,qh,qb)
+c
+c     Auteurs:   Calcul des valeurs de q aux point v.
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1)
+      real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm)
+      logical extremum(ip1jmp1,llm)
+
+      integer mode
+      save mode
+
+      data mode/1/
+
+c   calcul des pentes en u:
+c   -----------------------
+
+      if (mode.eq.0) then
+         do l=1,llm
+            do ij=1,ip1jmp1
+               qb(ij,l)=q(ij,l)
+               qh(ij,l)=q(ij,l)
+            enddo
+         enddo
+      else
+      do l = 2, llm
+         do ij=1,ip1jmp1
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l))
+         enddo
+      enddo
+      do ij=1,ip1jmp1
+         dzqw(ij,1)=0.
+         dzqw(ij,llm+1)=0.
+      enddo
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12.
+         enddo
+      enddo
+      do l=2,llm-1
+         do ij=1,ip1jmp1
+            extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0.
+         enddo
+      enddo
+
+c Pas de pentes en bas et en haut
+         do ij=1,ip1jmp1
+            zqw(ij,2)=q(ij,1)
+            zqw(ij,llm)=q(ij,llm)
+            extremum(ij,1)=.true.
+            extremum(ij,llm)=.true.
+         enddo
+
+c   calcul des valeurs max et min acceptees aux interfaces
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqmax(ij,l)=max(q(ij,l-1),q(ij,l))
+            zqmin(ij,l)=min(q(ij,l-1),q(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm
+         do ij=1,ip1jmp1
+            zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm-1
+         do ij=1,ip1jmp1
+            if(extremum(ij,l)) then
+               qh(ij,l)=q(ij,l)
+               qb(ij,l)=q(ij,l)
+            else
+               qh(ij,l)=zqw(ij,l+1)
+               qb(ij,l)=zqw(ij,l)
+            endif
+         enddo
+      enddo
+c     do l=2,llm-1
+c        do ij=1,ip1jmp1
+c           if(extremum(ij,l)) then
+c              if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l)
+c              if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l)
+c           endif
+c        enddo
+c     enddo
+
+      do ij=1,ip1jmp1
+         qb(ij,1)=q(ij,1)
+         qh(ij,1)=q(ij,1)
+         qb(ij,llm)=q(ij,llm)
+         qh(ij,llm)=q(ij,llm)
+      enddo
+
+      endif
+
+      RETURN
+      END
+
+      SUBROUTINE advnx(q,qg,qd,masse,u_m,mode)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      integer mode
+      real masse(ip1jmp1,llm)
+      real u_m( ip1jmp1,llm )
+      real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq
+      integer n0,nl(llm)
+c
+      real new_m,zu_m,zdq,zz
+      real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig
+      real u_mq(ip1jmp1,llm)
+
+      real zm,zq,zsigm,zsigp,zqm,zqp,zu
+
+      logical ladvplus(ip1jmp1,llm)
+
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+
+      do l=1,llm
+            do ij=iip2,ip1jm
+               zdq=qd(ij,l)-qg(ij,l)
+c              if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l
+c                 print*,qd(ij,l),q(ij,l),qg(ij,l)
+c                 qd(ij,l)=q(ij,l)
+c                 qg(ij,l)=q(ij,l)
+c              endif
+               if(abs(zdq).gt.prec) then
+                  zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq
+                  zsigg(ij,l)=1.-zsigd(ij,l)
+c                 if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and.
+c    s               zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then
+c                    print*,'probleme au point ij=',ij,'  l=',l
+c                    print*,'sigg=',zsigg(ij,l),'  sigd=',zsigd(ij,l)
+c                    print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq
+c                    stop
+c                 endif
+               else
+                  zsigd(ij,l)=0.5
+                  zsigg(ij,l)=0.5
+                  qd(ij,l)=q(ij,l)
+                  qg(ij,l)=q(ij,l)
+               endif
+            enddo
+       enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+       do l=1,llm
+       do ij=iip2,ip1jm-1
+          if (u_m(ij,l).ge.0.) then
+             zsigp=zsigd(ij,l)
+             zsigm=zsigg(ij,l)
+             zqp=qd(ij,l)
+             zqm=qg(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          else
+             zsigm=zsigd(ij+1,l)
+             zsigp=zsigg(ij+1,l)
+             zqm=qd(ij+1,l)
+             zqp=qg(ij+1,l)
+             zm=masse(ij+1,l)
+             zq=q(ij+1,l)
+          endif
+          zu=abs(u_m(ij,l))
+          ladvplus(ij,l)=zu.gt.zm
+          zsig=zu/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (mode.eq.1) then
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*zqp
+             else if (mode.eq.1) then
+                 u_mq(ij,l)=
+     s           sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm)
+             endif 
+          else
+             if (zsig.le.zsigp) then
+                 u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+             else
+                zz=0.5*(zsig-zsigp)/zsigm
+                u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp
+     s          +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+             endif
+          endif
+c         if(zsig.lt.0.) then
+c            print*,'au point ij=',ij,'  l=',l,'  sig=',zsig
+c            stop
+c         endif
+      enddo
+      enddo
+
+      do l=1,llm
+       do ij=iip1+iip1,ip1jm,iip1
+          u_mq(ij,l)=u_mq(ij-iim,l)
+          ladvplus(ij,l)=ladvplus(ij-iim,l)
+       enddo
+      enddo
+
+c=================================================================
+C   SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES
+c=================================================================
+c   tris des regions a traiter
+      n0=0
+      do l=1,llm
+         nl(l)=0
+         do ij=iip2,ip1jm
+            if(ladvplus(ij,l)) then
+               nl(l)=nl(l)+1
+               u_mq(ij,l)=0.
+            endif
+         enddo
+         n0=n0+nl(l)
+      enddo
+
+      if(n0.gt.1) then
+      IF (prt_level > 9) WRITE(lunout,*)
+     & 'Nombre de points pour lesquels on advect plus que le'
+     &       ,'contenu de la maille : ',n0
+
+         do l=1,llm
+            if(nl(l).gt.0) then
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               do ij=iip2,ip1jm
+                  if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then
+                     iju=iju+1
+                     indu(iju)=ij
+                  endif
+               enddo
+               niju=iju
+c              print*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               do iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  if(zu_m.gt.0.) then
+                     ijq=ij
+                     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)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   MODIFS SPECIFIQUES DU SCHEMA
+c   ajout de la maille non completement advectee
+             zsig=zu_m/masse(ijq,l)
+             if(zsig.le.zsigd(ijq,l)) then
+                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l)
+     s          -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l)))
+             else
+c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+c         goto 8888
+                zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l)
+                if(.not.(zz.gt.0..and.zz.le.0.5)) then
+                     WRITE(lunout,*)'probleme2 au point ij=',ij,
+     s               '  l=',l
+                     WRITE(lunout,*)'zz=',zz
+                     stop
+                endif
+                u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*(
+     s          0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l)
+     s        +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) )
+             endif
+                  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)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     enddo
+c   ajout de la maille non completement advectee
+c 2eme MODIF SPECIFIQUE
+             zsig=-zu_m/masse(ij+1,l)
+             if(zsig.le.zsigg(ijq,l)) then
+                u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l)
+     s          -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l)))
+             else
+c               u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l)
+c           goto 9999
+                zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l)
+                if(.not.(zz.gt.0..and.zz.le.0.5)) then
+                     WRITE(lunout,*)'probleme22 au point ij=',ij
+     s               ,'  l=',l
+                     WRITE(lunout,*)'zz=',zz
+                     stop
+                endif
+                u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*(
+     s          0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l)
+     s          +(zsig-zsigg(ijq,l))*
+     s           (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) )
+             endif
+c   fin de la modif
+                  endif
+               enddo
+            endif
+         enddo
+      endif  ! n0.gt.0 
+
+c   bouclage en latitude
+      do l=1,llm
+        do ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        enddo
+      enddo
+
+c=================================================================
+c   CALCUL DE LA CONVERGENCE DES FLUX
+c=================================================================
+
+      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)+
+     &      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)
+         do ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         enddo
+      enddo
+
+      RETURN
+      END
+      SUBROUTINE advny(q,qs,qn,masse,v_m)
+c
+c     Auteur : F. Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real masse(ip1jmp1,llm)
+      real v_m( ip1jm,llm )
+      real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real new_m,zdq,zz
+      real zsigs(ip1jmp1),zsign(ip1jmp1),zsig
+      real v_mq(ip1jm,llm)
+      real convpn,convps,convmpn,convmps,massen,masses
+      real zm,zq,zsigm,zsigp,zqm,zqp
+      real ssum
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-15/
+#endif
+      do l=1,llm
+            do ij=1,ip1jmp1
+               zdq=qn(ij,l)-qs(ij,l)
+c              if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l,'  advnqx'
+c                 print*,qn(ij,l),q(ij,l),qs(ij,l)
+c                 qn(ij,l)=q(ij,l)
+c                 qs(ij,l)=q(ij,l)
+c              endif
+               if(abs(zdq).gt.prec) then
+                  zsign(ij)=(q(ij,l)-qs(ij,l))/zdq
+                  zsigs(ij)=1.-zsign(ij)
+c                 if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and.
+c    s               zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then
+c                    print*,'probleme au point ij=',ij,'  l=',l
+c                    print*,'sigs=',zsigs(ij),'  sign=',zsign(ij)
+c                    stop
+c                 endif
+               else
+                  zsign(ij)=0.5
+                  zsigs(ij)=0.5
+               endif
+            enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+       do ij=1,ip1jm
+          if (v_m(ij,l).ge.0.) then
+             zsigp=zsign(ij+iip1)
+             zsigm=zsigs(ij+iip1)
+             zqp=qn(ij+iip1,l)
+             zqm=qs(ij+iip1,l)
+             zm=masse(ij+iip1,l)
+             zq=q(ij+iip1,l)
+          else
+             zsigm=zsign(ij)
+             zsigp=zsigs(ij)
+             zqm=qn(ij,l)
+             zqp=qs(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          endif
+          zsig=abs(v_m(ij,l))/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (zsig.le.zsigp) then
+              v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+          else
+              zz=0.5*(zsig-zsigp)/zsigm
+              v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp 
+     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+          endif
+       enddo
+      enddo
+
+      do l=1,llm
+         do ij=iip2,ip1jm
+            new_m=masse(ij,l)
+     &      +v_m(ij,l)-v_m(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l))
+     &         /new_m
+            masse(ij,l)=new_m
+         enddo
+c.-. ancienne version
+         convpn=SSUM(iim,v_mq(1,l),1)
+         convmpn=ssum(iim,v_m(1,l),1)
+         massen=ssum(iim,masse(1,l),1)
+         new_m=massen+convmpn
+         q(1,l)=(q(1,l)*massen+convpn)/new_m
+         do ij = 1,iip1
+            q(ij,l)=q(1,l)
+            masse(ij,l)=new_m*aire(ij)/apoln
+         enddo
+
+         convps=-SSUM(iim,v_mq(ip1jm-iim,l),1)
+         convmps=-ssum(iim,v_m(ip1jm-iim,l),1)
+         masses=ssum(iim,masse(ip1jm+1,l),1)
+         new_m=masses+convmps
+         q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m
+         do ij = ip1jm+1,ip1jmp1
+            q(ij,l)=q(ip1jm+1,l)
+            masse(ij,l)=new_m*aire(ij)/apols
+         enddo
+      enddo
+
+      RETURN
+      END
+      SUBROUTINE advnz(q,qh,qb,masse,w_m)
+c
+c     Auteurs:   F.Hourdin
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c     b designe le bas et h le haut
+c     il y a une correspondance entre le b en z et le d en x
+c    ********************************************************************
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "iniprint.h"
+c
+c
+c   Arguments:
+c   ----------
+      real masse(ip1jmp1,llm)
+      real w_m( ip1jmp1,llm+1)
+      real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm)
+
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      real new_m,zdq,zz
+      real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig
+      real w_mq(ip1jmp1,llm+1)
+      real zm,zq,zsigm,zsigp,zqm,zqp
+      real prec
+      save prec
+
+#ifdef CRAY
+      data prec/1.e-24/
+#else
+      data prec/1.e-13/
+#endif
+
+      do l=1,llm
+            do ij=1,ip1jmp1
+               zdq=qb(ij,l)-qh(ij,l)
+c              if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then
+c                 print*,'probleme au point ij=',ij,'  l=',l
+c                 print*,qh(ij,l),q(ij,l),qb(ij,l)
+c                 qh(ij,l)=q(ij,l)
+c                 qb(ij,l)=q(ij,l)
+c              endif
+
+               if(abs(zdq).gt.prec) then
+                  zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq
+                  zsigh(ij,l)=1.-zsigb(ij,l)
+                  zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.)
+               else
+                  zsigb(ij,l)=0.5
+                  zsigh(ij,l)=0.5
+               endif
+            enddo
+       enddo
+
+c      print*,'ok1'
+c   calcul de la pente maximum dans la maille en valeur absolue
+       do l=2,llm
+       do ij=1,ip1jmp1
+          if (w_m(ij,l).ge.0.) then
+             zsigp=zsigb(ij,l)
+             zsigm=zsigh(ij,l)
+             zqp=qb(ij,l)
+             zqm=qh(ij,l)
+             zm=masse(ij,l)
+             zq=q(ij,l)
+          else
+             zsigm=zsigb(ij,l-1)
+             zsigp=zsigh(ij,l-1)
+             zqm=qb(ij,l-1)
+             zqp=qh(ij,l-1)
+             zm=masse(ij,l-1)
+             zq=q(ij,l-1)
+          endif
+          zsig=abs(w_m(ij,l))/zm
+          if(zsig.eq.0.) zsigp=0.1
+          if (zsig.le.zsigp) then
+              w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq))
+          else
+              zz=0.5*(zsig-zsigp)/zsigm
+              w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp
+     s        +(zsig-zsigp)*(zq+zz*(zqm-zq)) )
+          endif
+      enddo
+      enddo
+
+       do ij=1,ip1jmp1
+          w_mq(ij,llm+1)=0.
+          w_mq(ij,1)=0.
+       enddo
+
+      do l=1,llm
+         do ij=1,ip1jmp1
+            new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l))
+     &         /new_m
+            masse(ij,l)=new_m
+         enddo
+      enddo
+c     print*,'ok3'
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advtrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advtrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advtrac.h	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'advtrac.h'
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+
+      COMMON/advtr/iadv, hadv, vadv, tnom, tname, ttext, niadv,         &
+     &   nbtrac, nprath, mmt_adj, hadv_flg, vadv_flg, conv_flg,         &
+     &   pbl_flg, tracnam
+      INTEGER iadv(nqmx) ! indice schema de transport 
+      INTEGER hadv(nqmx) ! indice schema transport horizontal 
+      INTEGER vadv(nqmx) ! indice schema transport vertical 
+      INTEGER niadv(nqmx) ! equivalent dyn / physique
+      character (len=8) :: tnom(nqmx) ! nom court du traceur
+      character (len=10) :: tname(nqmx) ! nom du traceur pour restart
+      character (len=13) :: ttext(nqmx) ! nom long du traceur pour sorties
+
+
+      integer nbtrac
+      integer nprath
+      real    mmt_adj(iim+1,jjm+1,llm, 1) 
+      integer hadv_flg(nqmx)
+      integer vadv_flg(nqmx)
+      integer conv_flg(nqmx-2) 
+      integer pbl_flg(nqmx-2)
+      character (len=8) :: tracnam(nqmx-2) 
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advtrac_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advtrac_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advtrac_p.F	(revision 984)
@@ -0,0 +1,484 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE advtrac_p(pbaru,pbarv ,
+     *                   p,  masse,q,iapptrac,teta,
+     *                  flxw,
+     *                  pk   )
+
+c     Auteur :  F. Hourdin
+c
+c     Modif. P. Le Van     (20/12/97)
+c            F. Codron     (10/99)
+c            D. Le Croller (07/2001)
+c            M.A Filiberti (04/2002)
+c
+      USE parallel
+      USE Write_Field_p
+      USE Bands
+      USE mod_hallo
+      USE Vampir
+      USE times
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comdissip.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "advtrac.h"
+
+c-------------------------------------------------------------------
+c     Arguments
+c-------------------------------------------------------------------
+c     Ajout PPM
+c--------------------------------------------------------
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm)
+c--------------------------------------------------------
+      INTEGER iapptrac
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL q(ip1jmp1,llm,nqmx),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm)
+      REAL pk(ip1jmp1,llm)
+      REAL               :: flxw(ip1jmp1,llm)
+
+c-------------------------------------------------------------
+c     Variables locales
+c-------------------------------------------------------------
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+      REAL,SAVE::pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) 
+      REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu
+      real cpuadv(nqmx)
+      common/cpuadv/cpuadv
+
+      INTEGER iadvtr
+      INTEGER ij,l,iq,iiq
+      REAL zdpmin, zdpmax
+      SAVE iadvtr, massem, pbaruc, pbarvc
+      DATA iadvtr/0/
+c$OMP THREADPRIVATE(iadvtr)
+c----------------------------------------------------------
+c     Rajouts pour PPM
+c----------------------------------------------------------
+      INTEGER indice,n
+      REAL dtbon ! Pas de temps adaptatif pour que CFL<1
+      REAL CFLmaxz,aaa,bbb ! CFL maximum
+      REAL psppm(iim,jjp1) ! pression  au sol
+      REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm)
+      REAL qppm(iim*jjp1,llm,nqmx)
+      REAL fluxwppm(iim,jjp1,llm)
+      REAL apppm(llmp1), bpppm(llmp1)
+      LOGICAL dum,fill
+      DATA fill/.true./
+      DATA dum/.true./
+      REAL finmasse(ip1jmp1,llm)
+      integer ijb,ije,ijb_u,ijb_v,ije_u,ije_v,j
+      type(Request) :: Request_vanleer
+      REAL,SAVE :: p_tmp( ip1jmp1,llmp1 )
+      REAL,SAVE :: teta_tmp(ip1jmp1,llm)
+      REAL,SAVE :: pk_tmp(ip1jmp1,llm)
+      
+      ijb_u=ij_begin
+      ije_u=ij_end
+      
+      ijb_v=ij_begin-iip1
+      ije_v=ij_end
+      if (pole_nord) ijb_v=ij_begin
+      if (pole_sud)  ije_v=ij_end-iip1
+
+      IF(iadvtr.EQ.0) THEN
+c         CALL initial0(ijp1llm,pbaruc)
+c         CALL initial0(ijmllm,pbarvc)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+	DO l=1,llm   
+          pbaruc(ijb_u:ije_u,l)=0.
+          pbarvc(ijb_v:ije_v,l)=0.
+        ENDDO
+c$OMP END DO NOWAIT  
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij = ijb_u,ije_u
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+         ENDDO
+         DO ij = ijb_v,ije_v
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+
+c         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+          ijb=ij_begin
+          ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,llm
+          massem(ijb:ije,l)=masse(ijb:ije,l)
+       ENDDO
+c$OMP END DO NOWAIT
+
+ccc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+c
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+c$OMP MASTER
+      iapptrac = iadvtr
+c$OMP END MASTER
+
+c   Test pour savoir si on advecte a ce pas de temps
+
+      IF ( iadvtr.EQ.iapp_tracvl ) THEN
+c$OMP MASTER
+        call suspend_timer(timer_caldyn)
+c$OMP END MASTER
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+
+cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
+cc
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+c$OMP BARRIER
+        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+c$OMP BARRIER
+
+c$OMP BARRIER
+c$OMP MASTER      
+      p_tmp(ijb:ije,1:llmp1)=p(ijb:ije,1:llmp1)
+      pk_tmp(ijb:ije,1:llm)=pk(ijb:ije,1:llm)
+      teta_tmp(ijb:ije,1:llm)=teta(ijb:ije,1:llm)
+      call VTb(VTHallo)
+      call Register_SwapFieldHallo(pbarug,pbarug,ip1jmp1,llm,
+     *                             jj_Nb_vanleer,0,0,Request_vanleer)
+      call Register_SwapFieldHallo(pbarvg,pbarvg,ip1jm,llm,
+     *                             jj_Nb_vanleer,1,0,Request_vanleer)
+      call Register_SwapFieldHallo(massem,massem,ip1jmp1,llm,
+     *                             jj_Nb_vanleer,0,0,Request_vanleer)
+      call Register_SwapFieldHallo(wg,wg,ip1jmp1,llm,
+     *                             jj_Nb_vanleer,0,0,Request_vanleer)
+      call Register_SwapFieldHallo(teta_tmp,teta_tmp,ip1jmp1,llm,
+     *                             jj_Nb_vanleer,1,1,Request_vanleer)
+      call Register_SwapFieldHallo(p_tmp,p_tmp,ip1jmp1,llmp1,
+     *                             jj_Nb_vanleer,1,1,Request_vanleer)
+      call Register_SwapFieldHallo(pk_tmp,pk_tmp,ip1jmp1,llm,
+     *                             jj_Nb_vanleer,1,1,Request_vanleer)
+      do j=1,nqmx
+        call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     *                             jj_nb_vanleer,0,0,Request_vanleer)
+      enddo
+      
+      call SetDistrib(jj_nb_vanleer)
+      call SendRequest(Request_vanleer)
+      call WaitRequest(Request_vanleer)
+
+      call VTe(VTHallo)
+      
+      call VTb(VTadvection)
+      call start_timer(timer_vanleer)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      ! ... Flux de masse diaganostiques traceurs
+         ijb=ij_begin
+         ije=ij_end
+         flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/FLOAT(iapp_tracvl)
+
+c  test sur l'eventuelle creation de valeurs negatives de la masse
+         ijb=ij_begin
+         ije=ij_end
+         if (pole_nord) ijb=ij_begin+iip1
+         if (pole_sud) ije=ij_end-iip1
+         
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+         DO l=1,llm-1
+            DO ij = ijb+1,ije
+              zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l)
+     s                  - pbarvg(ij-iip1,l) + pbarvg(ij,l)
+     s                  +       wg(ij,l+1)  - wg(ij,l)
+            ENDDO
+            
+c            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+c ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
+            
+            do ij=ijb,ije-iip1+1,iip1
+              zdp(ij)=zdp(ij+iip1-1)
+            enddo
+            
+            DO ij = ijb,ije
+               zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+            ENDDO 
+
+
+c            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+c  ym ---> eventuellement a revoir
+            CALL minmax ( ije-ijb+1, zdp(ijb), zdpmin,zdpmax )
+            
+            IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+            PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin,
+     s        '   MAX:', zdpmax
+            ENDIF
+
+         ENDDO
+c$OMP END DO NOWAIT
+
+c-------------------------------------------------------------------
+c   Advection proprement dite (Modification Le Croller (07/2001)
+c-------------------------------------------------------------------
+
+c----------------------------------------------------
+c        Calcul des moyennes basées sur la masse
+c----------------------------------------------------
+
+cym      ----> Normalement, inutile pour les schémas classiques
+cym      ----> Revérifier lors de la parallélisation des autres schemas
+   
+cym          call massbar_p(massem,massebx,masseby)          
+
+          call vlspltgen_p( q,iadv, 2., massem, wg ,
+     *                    pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp )
+
+         
+	  GOTO 1234     
+c-----------------------------------------------------------
+c     Appel des sous programmes d'advection
+c-----------------------------------------------------------
+      do iq=1,nqmx
+c        call clock(t_initial)
+        if(iadv(iq) == 0) cycle 
+c   ----------------------------------------------------------------
+c   Schema de Van Leer I MUSCL
+c   ----------------------------------------------------------------
+        if(iadv(iq).eq.10) THEN
+     
+	    call vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
+
+c   ----------------------------------------------------------------
+c   Schema "pseudo amont" + test sur humidite specifique
+C    pour la vapeur d'eau. F. Codron
+c   ----------------------------------------------------------------
+        else if(iadv(iq).eq.14) then
+c
+cym           stop 'advtrac : appel à vlspltqs :schema non parallelise'
+           CALL vlspltqs_p( q(1,1,1), 2., massem, wg ,
+     *                 pbarug,pbarvg,dtvr,p_tmp,pk_tmp,teta_tmp )
+c   ----------------------------------------------------------------
+c   Schema de Frederic Hourdin
+c   ----------------------------------------------------------------
+        else if(iadv(iq).eq.12) then
+          stop 'advtrac : schema non parallelise'
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+           do indice=1,n
+            call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+           end do
+        else if(iadv(iq).eq.13) then
+          stop 'advtrac : schema non parallelise'
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+          do indice=1,n
+            call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+          end do
+c   ----------------------------------------------------------------
+c   Schema de pente SLOPES
+c   ----------------------------------------------------------------
+        else if (iadv(iq).eq.20) then
+          stop 'advtrac : schema non parallelise'
+
+            call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+c   ----------------------------------------------------------------
+c   Schema de Prather
+c   ----------------------------------------------------------------
+        else if (iadv(iq).eq.30) then
+          stop 'advtrac : schema non parallelise'
+c            Pas de temps adaptatif
+           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+           if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+           endif
+           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg,
+     s                     n,dtbon)
+c   ----------------------------------------------------------------
+c   Schemas PPM Lin et Rood
+c   ----------------------------------------------------------------
+       else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND.
+     s                     iadv(iq).LE.18)) then
+
+           stop 'advtrac : schema non parallelise'
+
+c        Test sur le flux horizontal
+c        Pas de temps adaptatif
+         call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
+         if (n.GT.1) then
+           write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',
+     s             dtvr,'n=',n
+         endif
+c        Test sur le flux vertical
+         CFLmaxz=0.
+         do l=2,llm
+           do ij=iip2,ip1jm
+            aaa=wg(ij,l)*dtvr/massem(ij,l)
+            CFLmaxz=max(CFLmaxz,aaa)
+            bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+            CFLmaxz=max(CFLmaxz,bbb)
+           enddo
+         enddo
+         if (CFLmaxz.GE.1) then
+            write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+         endif
+
+c-----------------------------------------------------------
+c        Ss-prg interface LMDZ.4->PPM3d
+c-----------------------------------------------------------
+
+          call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem,
+     s                 apppm,bpppm,massebx,masseby,pbarug,pbarvg,
+     s                 unatppm,vnatppm,psppm)
+
+          do indice=1,n
+c---------------------------------------------------------------------
+c                         VL (version PPM) horiz. et PPM vert.
+c---------------------------------------------------------------------
+                if (iadv(iq).eq.11) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+
+c----------------------------------------------------------------------
+c                           Monotonic PPM
+c----------------------------------------------------------------------
+               else if (iadv(iq).eq.16) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c                           Semi Monotonic PPM
+c---------------------------------------------------------------------
+               else if (iadv(iq).eq.17) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c                         Positive Definite PPM
+c---------------------------------------------------------------------
+                else if (iadv(iq).eq.18) then
+c                  Ss-prg PPM3d de Lin
+                  call ppm3d(1,qppm(1,1,iq),
+     s                       psppm,psppm,
+     s                       unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1,
+     s                       iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,
+     s                       fill,dum,220.)
+c---------------------------------------------------------------------
+                endif
+            enddo
+c-----------------------------------------------------------------
+c               Ss-prg interface PPM3d-LMDZ.4
+c-----------------------------------------------------------------
+                  call interpost(q(1,1,iq),qppm(1,1,iq))
+            endif
+c----------------------------------------------------------------------
+
+c-----------------------------------------------------------------
+c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
+c et Nord j=1
+c-----------------------------------------------------------------
+
+c                  call traceurpole(q(1,1,iq),massem)
+
+c calcul du temps cpu pour un schema donne
+
+c                  call clock(t_final)
+cym                  tps_cpu=t_final-t_initial
+cym                  cpuadv(iq)=cpuadv(iq)+tps_cpu
+
+       end DO
+
+1234  CONTINUE
+c$OMP BARRIER
+c$OMP MASTER
+      ijb=ij_begin
+      ije=ij_end
+      
+       DO l = 1, llm
+         DO ij = ijb, ije
+           finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+         ENDDO
+       ENDDO
+
+
+       CALL qminimum_p( q, 2, finmasse )
+
+c------------------------------------------------------------------
+c   on reinitialise a zero les flux de masse cumules
+c---------------------------------------------------
+c          iadvtr=0
+	call VTe(VTadvection)
+        call stop_timer(timer_vanleer)
+
+        call VTb(VThallo)
+	do j=1,nqmx
+          call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     *                             jj_nb_caldyn,0,0,Request_vanleer)
+        enddo
+
+        call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm,
+     *       jj_nb_caldyn,0,0,Request_vanleer)
+
+        call SetDistrib(jj_nb_caldyn)
+        call SendRequest(Request_vanleer)
+        call WaitRequest(Request_vanleer)      
+        
+	call VTe(VThallo)
+	call resume_timer(timer_caldyn)
+c$OMP END MASTER
+c$OMP BARRIER	
+          iadvtr=0
+       ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advx.F	(revision 984)
@@ -0,0 +1,497 @@
+!
+! $Header$
+!
+      SUBROUTINE  advx(limit,dtx,pbaru,sm,s0,
+     $     sx,sy,sz,lati,latf)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (FOM) advection of tracer in X direction  C
+C                                                                C
+C  Source : Pascal Simon (Meteo,CNRM)                            C
+C  Adaptation : A.Armengaud (LGGE) juin 94                       C
+C                                                                C
+C  limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz                       C
+C  sont des arguments d'entree pour le s-pg...                   C
+C                                                                C
+C  sm,s0,sx,sy,sz                                                C
+C  sont les arguments de sortie pour le s-pg                     C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+C  Arguments :
+C  -----------
+C  dtx : frequence fictive d'appel du transport 
+C  pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1
+
+       INTEGER ntra
+       PARAMETER (ntra = 1)
+
+C ATTENTION partout ou on trouve ntra, insertion de boucle
+C           possible dans l'avenir.
+
+      REAL dtx
+      REAL pbaru ( iip1,jjp1,llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm),S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     $    ,sy(iip1,jjp1,llm,ntra)
+      REAL sz(iip1,jjp1,llm,ntra)
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL UGRI(iip1,jjp1,llm)
+
+C  Rem : VGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en x uniquement )
+C
+C  Ti are the moments for the current latitude and level
+C
+      REAL TM(iim)
+      REAL T0(iim,ntra),TX(iim,ntra)
+      REAL TY(iim,ntra),TZ(iim,ntra)
+      REAL TEMPTM                ! just a temporary variable
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL FM(iim)
+      REAL F0(iim,ntra),FX(iim,ntra)
+      REAL FY(iim,ntra),FZ(iim,ntra)
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+C
+      REAL SMNEW(iim),UEXT(iim)
+C
+      REAL sqi,sqf
+
+      LOGICAL LIMIT
+      INTEGER NUM(jjp1),LONK,NUMK
+      INTEGER lon,lati,latf,niv
+      INTEGER i,i2,i3,j,jv,l,k,itrac 
+
+      lon = iim 
+      niv = llm 
+
+C *** Test de passage d'arguments ******
+
+
+C  -------------------------------------
+      DO 300 j = 1,jjp1 
+         NUM(j) = 1
+  300 CONTINUE
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+               sqi = sqi + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------'
+      PRINT*,'sqi=',sqi
+
+
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  ---------------------------------------------------------
+C  Conversion des flux de masses en kg/s
+C  pbaru est en N/s d'ou :
+C  ugri est en kg/s
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjm+1
+            DO 500 i = 1,iip1  
+C            ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g )
+             ugri (i,j,llm+1-l) = pbaru (i,j,l)
+  500 CONTINUE
+
+
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+C  ---------------------------------------------------------
+  
+C  start here          
+C
+C  boucle principale sur les niveaux et les latitudes
+C
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+C
+C  modifications for extended polar zones
+C
+      NUMK=NUM(K)
+      LONK=LON/NUMK
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0(I,JV)=0.
+         TX(I,JV)=0.
+         TY(I,JV)=0.
+         TZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TM(I)=TM(I)+SM(I3,K,L)
+            ALF(I)=SM(I3,K,L)/TM(I)
+            ALF1(I)=1.-ALF(I)
+ 113     CONTINUE
+C
+         DO  JV=1,NTRA
+         DO  I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)
+     $          *S0(I3,K,L,JV)
+            T0(I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+            TX(I,JV)=ALF(I)  *sx(I3,K,L,JV)+
+     $       ALF1(I)*TX(I,JV) +3.*TEMPTM
+            TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV)
+            TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV)
+         ENDDO 
+         ENDDO
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 I=1,LON
+         T0(I,JV)=S0(I,K,L,JV)
+         TX(I,JV)=sx(I,K,L,JV)
+         TY(I,JV)=sy(I,K,L,JV)
+         TZ(I,JV)=sz(I,K,L,JV)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 13
+C
+      DO 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV))
+ 120  CONTINUE
+ 12   CONTINUE
+C
+ 13   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from IP to I if U(I).lt.0
+C
+      DO 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+        FM(I)=-UEXT(I)*DTX
+        ALF(I)=FM(I)/TM(1)
+        TM(1)=TM(1)-FM(I)
+      ENDIF
+C
+C  flux from I to IP if U(I).gt.0
+C
+      DO 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           F0(I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*TX(I+1,JV) )
+           FX(I,JV)=ALFQ(I)*TX(I+1,JV)
+           FY(I,JV)=ALF (I)*TY(I+1,JV)
+           FZ(I,JV)=ALF (I)*TZ(I+1,JV)
+C
+           T0(I+1,JV)=T0(I+1,JV)-F0(I,JV)
+           TX(I+1,JV)=ALF1Q(I)*TX(I+1,JV)
+           TY(I+1,JV)=TY(I+1,JV)-FY(I,JV)
+           TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,JV)
+C
+         ENDIF
+C
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 JV=1,NTRA
+C
+           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*TX(1,JV) )
+           FX (I,JV)=ALFQ(I)*TX(1,JV)
+           FY (I,JV)=ALF (I)*TY(1,JV)
+           FZ (I,JV)=ALF (I)*TZ(1,JV)
+C
+           T0(1,JV)=T0(1,JV)-F0(I,JV)
+           TX(1,JV)=ALF1Q(I)*TX(1,JV)
+           TY(1,JV)=TY(1,JV)-FY(I,JV)
+           TZ(1,JV)=TZ(1,JV)-FZ(I,JV)
+C
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           F0(I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*TX(I,JV) )
+           FX(I,JV)=ALFQ(I)*TX(I,JV)
+           FY(I,JV)=ALF (I)*TY(I,JV)
+           FZ(I,JV)=ALF (I)*TZ(I,JV)
+C
+           T0(I,JV)=T0(I,JV)-F0(I,JV)
+           TX(I,JV)=ALF1Q(I)*TX(I,JV)
+           TY(I,JV)=TY(I,JV)-FY(I,JV)
+           TZ(I,JV)=TZ(I,JV)-FZ(I,JV)
+C
+         ENDIF
+C
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+           T0(I,JV)=T0(I,JV)+F0(I,JV)
+           TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+           TY(I,JV)=TY(I,JV)+FY(I,JV)
+           TZ(I,JV)=TZ(I,JV)+FZ(I,JV)
+C
+         ENDIF
+C
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+           T0(I+1,JV)=T0(I+1,JV)+F0(I,JV)
+           TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM
+           TY(I+1,JV)=TY(I+1,JV)+FY(I,JV)
+           TZ(I+1,JV)=TZ(I+1,JV)+FZ(I,JV)
+C
+         ENDIF
+C
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 JV=1,NTRA
+           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+           T0(1,JV)=T0(1,JV)+F0(I,JV)
+           TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+           TY(1,JV)=TY(1,JV)+FY(I,JV)
+           TZ(1,JV)=TZ(1,JV)+FZ(I,JV)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 180 I2=1,NUMK
+C
+         DO 180 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            SM(I3,K,L)=SMNEW(I3)
+            ALF(I)=SMNEW(I3)/TM(I)
+            TM(I)=TM(I)-SMNEW(I3)
+C
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1(I)=1.-ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 180     CONTINUE
+C
+         DO  JV=1,NTRA
+         DO  I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            S0(I3,K,L,JV)=ALF (I)
+     $       * (T0(I,JV)-ALF1(I)*TX(I,JV))
+            sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV)
+            sy(I3,K,L,JV)=ALF (I)*TY(I,JV)
+            sz(I3,K,L,JV)=ALF (I)*TZ(I,JV)
+C
+C   reajusts moments remaining in the box
+C
+            T0(I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+            TX(I,JV)=ALF1Q(I)*TX(I,JV)
+            TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV)
+            TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV)
+          ENDDO
+          ENDDO
+C
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 I=1,LON
+         S0(I,K,L,JV)=T0(I,JV)
+         sx(I,K,L,JV)=TX(I,JV)
+         sy(I,K,L,JV)=TY(I,JV)
+         sz(I,K,L,JV)=TZ(I,JV)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+c OK
+c      DO 9998 l = 1, llm
+c      DO 9998 j = 1, jjp1
+c      DO 9998 i = 1, iip1
+c         IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
+c            PRINT*, '-------------------'
+c            PRINT*, 'En fin de ADVX'
+c            PRINT*,'SM(',i,j,l,')=',SM(i,j,l)
+c            PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c            print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c            print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c            print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVX1'
+cc            STOP
+c         ENDIF
+c 9998 CONTINUE
+c
+C ---------- bouclage cyclique 
+      DO itrac=1,ntra
+      DO l = 1,llm
+        DO j = lati,latf
+           SM(iip1,j,l) = SM(1,j,l)
+           S0(iip1,j,l,itrac) = S0(1,j,l,itrac)
+           sx(iip1,j,l,itrac) = sx(1,j,l,itrac)
+           sy(iip1,j,l,itrac) = sy(1,j,l,itrac)
+           sz(iip1,j,l,itrac) = sz(1,j,l,itrac)
+        END DO
+      END DO
+      ENDDO 
+
+c ----------- qqtite totale de traceur dans tte l'atmosphere
+      DO l = 1, llm
+        DO j = 1, jjp1
+          DO i = 1, iim
+             sqf = sqf + S0(i,j,l,ntra)
+          END DO  
+        END DO
+      END DO
+c
+      PRINT*,'------ DIAG DANS ADVX - SORTIE -----'
+      PRINT*,'sqf=',sqf
+c-------------
+
+      RETURN
+      END
+C_________________________________________________________________
+C_________________________________________________________________
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advxp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advxp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advxp.F	(revision 984)
@@ -0,0 +1,650 @@
+!
+! $Header$
+!
+       SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ
+     .                ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra)
+       IMPLICIT NONE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in X direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+       INTEGER ntra
+c      PARAMETER (ntra = 1)
+C
+C  definition de la grille du modele
+C
+      REAL dtx
+      REAL pbaru ( iip1,jjp1,llm )
+C
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C           Sij 2nd  order moment in i and j directions
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+      REAL SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+
+C  Local :
+C  -------
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+       REAL UGRI(iip1,jjp1,llm)
+
+C  Rem : VGRI et WGRI ne sont pas utilises dans
+C  cette subroutine ( advection en x uniquement )
+C
+C
+C  Tij are the moments for the current latitude and level
+C
+      REAL TM (iim)
+      REAL T0 (iim,NTRA),TX (iim,NTRA)
+      REAL TY (iim,NTRA),TZ (iim,NTRA)
+      REAL TXX(iim,NTRA),TXY(iim,NTRA)
+      REAL TXZ(iim,NTRA),TYY(iim,NTRA)
+      REAL TYZ(iim,NTRA),TZZ(iim,NTRA)
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL FM (iim)
+      REAL F0 (iim,NTRA),FX (iim,NTRA)
+      REAL FY (iim,NTRA),FZ (iim,NTRA)
+      REAL FXX(iim,NTRA),FXY(iim,NTRA)
+      REAL FXZ(iim,NTRA),FYY(iim,NTRA)
+      REAL FYZ(iim,NTRA),FZZ(iim,NTRA)
+C
+C  work arrays
+C
+      REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+      REAL ALF2(iim),ALF3(iim),ALF4(iim)
+C
+      REAL SMNEW(iim),UEXT(iim)
+      REAL sqi,sqf
+      REAL TEMPTM
+      REAL SLPMAX
+      REAL S1MAX,S1NEW,S2NEW
+
+      LOGICAL LIMIT
+      INTEGER NUM(jjp1),LONK,NUMK
+      INTEGER lon,lati,latf,niv
+      INTEGER i,i2,i3,j,jv,l,k,iter
+
+      lon = iim
+      lati=2
+      latf = jjm
+      niv = llm
+
+C *** Test de passage d'arguments ******
+
+c      DO 399 l = 1, llm
+c       DO 399 j = 1, jjp1
+c        DO 399 i = 1, iip1
+c         IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+c         PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c	     print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+c         print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+c         print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+c         PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP'
+cc            STOP
+c         ENDIF
+c  399 CONTINUE
+
+C *** Test : diagnostique de la qtite totale de traceur
+C            dans l'atmosphere avant l'advection
+c
+      sqi =0.
+      sqf =0.
+c
+      DO l = 1, llm
+      DO j = 1, jjp1
+      DO i = 1, iim
+	 sqi = sqi + S0(i,j,l,ntra)
+      END DO
+      END DO
+      END DO
+      PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----'
+      PRINT*,'sqi=',sqi
+c test
+c  -------------------------------------
+        DO 300 j =1,jjp1
+         NUM(j) =1 
+ 300  CONTINUE
+c       DO l=1,llm
+c      NUM(2,l)=6
+c      NUM(3,l)=6
+c      NUM(jjm-1,l)=6  
+c      NUM(jjm,l)=6
+c      ENDDO
+c        DO j=2,6
+c       NUM(j)=12
+c       ENDDO
+c       DO j=jjm-5,jjm-1 
+c       NUM(j)=12
+c       ENDDO
+
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  ---------------------------------------------------------
+C  Conversion des flux de masses en kg/s
+C  pbaru est en N/s d'ou :
+C  ugri est en kg/s
+
+       DO 500 l = 1,llm
+       DO 500 j = 1,jjp1
+       DO 500 i = 1,iip1
+       ugri (i,j,llm+1-l) =pbaru (i,j,l) 
+ 500   CONTINUE
+
+C  ---------------------------------------------------------
+C  start here
+C
+C  boucle principale sur les niveaux et les latitudes
+C     
+      DO 1 L=1,NIV
+      DO 1 K=lati,latf
+
+C
+C  initialisation
+C
+C  program assumes periodic boundaries in X
+C
+      DO 10 I=2,LON
+         SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX
+ 10   CONTINUE
+      SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX
+C
+C  modifications for extended polar zones
+C
+      NUMK=NUM(K)
+      LONK=LON/NUMK
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 111 I=1,LON
+         TM(I)=0.
+ 111  CONTINUE
+      DO 112 JV=1,NTRA
+      DO 1120 I=1,LON
+         T0 (I,JV)=0.
+         TX (I,JV)=0.
+         TY (I,JV)=0.
+         TZ (I,JV)=0.
+         TXX(I,JV)=0.
+         TXY(I,JV)=0.
+         TXZ(I,JV)=0.
+         TYY(I,JV)=0.
+         TYZ(I,JV)=0.
+         TZZ(I,JV)=0.
+ 1120 CONTINUE
+ 112  CONTINUE
+C
+      DO 11 I2=1,NUMK
+C
+         DO 113 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TM(I)=TM(I)+SM(I3,K,L)
+            ALF(I)=SM(I3,K,L)/TM(I)
+            ALF1(I)=1.-ALF(I)
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+            ALF2(I)=ALF1(I)-ALF(I)
+            ALF3(I)=ALF(I)*ALF1(I)
+ 113     CONTINUE
+C
+         DO 114 JV=1,NTRA
+         DO 1140 I=1,LONK
+            I3=(I-1)*NUMK+I2
+            TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV)
+            T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV)
+            TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV)
+     +        +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+            TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM
+            TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV)
+     +           +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV))
+            TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV)
+     +           +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV))
+            TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV)
+            TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV)
+            TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV)
+            TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV)
+            TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV)
+ 1140    CONTINUE
+ 114     CONTINUE
+C
+ 11   CONTINUE
+C
+      ELSE
+C
+      DO 115 I=1,LON
+         TM(I)=SM(I,K,L)
+ 115  CONTINUE
+      DO 116 JV=1,NTRA
+      DO 1160 I=1,LON
+         T0 (I,JV)=S0 (I,K,L,JV)
+         TX (I,JV)=SSX (I,K,L,JV)
+         TY (I,JV)=SY (I,K,L,JV)
+         TZ (I,JV)=SZ (I,K,L,JV)
+         TXX(I,JV)=SSXX(I,K,L,JV)
+         TXY(I,JV)=SSXY(I,K,L,JV)
+         TXZ(I,JV)=SSXZ(I,K,L,JV)
+         TYY(I,JV)=SYY(I,K,L,JV)
+         TYZ(I,JV)=SYZ(I,K,L,JV)
+         TZZ(I,JV)=SZZ(I,K,L,JV)
+ 1160 CONTINUE
+ 116  CONTINUE
+C
+      ENDIF
+C
+      DO 117 I=1,LONK
+         UEXT(I)=UGRI(I*NUMK,K,L)
+ 117  CONTINUE
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 13
+C
+      DO 12 JV=1,NTRA
+      DO 120 I=1,LONK
+        IF(T0(I,JV).GT.0.) THEN
+          SLPMAX=T0(I,JV)
+          S1MAX=1.5*SLPMAX
+          S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV)))
+          S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                 AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) )
+          TX (I,JV)=S1NEW
+          TXX(I,JV)=S2NEW
+          TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV)))
+          TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV)))
+        ELSE
+          TX (I,JV)=0.
+          TXX(I,JV)=0.
+          TXY(I,JV)=0.
+          TXZ(I,JV)=0.
+        ENDIF
+ 120  CONTINUE
+ 12   CONTINUE
+C
+ 13   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from IP to I if U(I).lt.0
+C
+      DO 140 I=1,LONK-1
+         IF(UEXT(I).LT.0.) THEN
+           FM(I)=-UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I+1)
+           TM(I+1)=TM(I+1)-FM(I)
+         ENDIF
+ 140  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+        FM(I)=-UEXT(I)*DTX
+        ALF(I)=FM(I)/TM(1)
+        TM(1)=TM(1)-FM(I)
+      ENDIF
+C
+C  flux from I to IP if U(I).gt.0
+C
+      DO 141 I=1,LONK
+         IF(UEXT(I).GE.0.) THEN
+           FM(I)=UEXT(I)*DTX
+           ALF(I)=FM(I)/TM(I)
+           TM(I)=TM(I)-FM(I)
+         ENDIF
+ 141  CONTINUE
+C
+      DO 142 I=1,LONK
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1(I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF1(I)-ALF(I)
+         ALF3(I)=ALF(I)*ALFQ(I)
+         ALF4(I)=ALF1(I)*ALF1Q(I)
+ 142  CONTINUE
+C
+      DO 150 JV=1,NTRA
+      DO 1500 I=1,LONK-1
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)*
+     +             ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV))
+           FXX(I,JV)=ALF3(I)*TXX(I+1,JV)
+           FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV))
+           FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(I+1,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV)
+           FYY(I,JV)=ALF (I)*TYY(I+1,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(I+1,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(I+1,JV)
+C
+           T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV)
+           TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV))
+           TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV)
+           TY (I+1,JV)=TY (I+1,JV)-FY (I,JV)
+           TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV)
+           TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV)
+           TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV)
+           TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV)
+           TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV)
+           TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV)
+C
+         ENDIF
+C
+ 1500 CONTINUE
+ 150  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).LT.0.) THEN
+C
+        DO 151 JV=1,NTRA
+C
+           F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)*
+     +             ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV))
+           FXX(I,JV)=ALF3(I)*TXX(1,JV)
+           FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV))
+           FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(1,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(1,JV)
+           FYY(I,JV)=ALF (I)*TYY(1,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(1,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(1,JV)
+C
+           T0 (1,JV)=T0(1,JV)-F0(I,JV)
+           TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV))
+           TXX(1,JV)=ALF4(I)*TXX(1,JV)
+           TY (1,JV)=TY (1,JV)-FY (I,JV)
+           TZ (1,JV)=TZ (1,JV)-FZ (I,JV)
+           TYY(1,JV)=TYY(1,JV)-FYY(I,JV)
+           TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV)
+           TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV)
+           TXY(1,JV)=ALF1Q(I)*TXY(1,JV)
+           TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV)
+C
+ 151    CONTINUE
+C
+      ENDIF
+C
+      DO 152 JV=1,NTRA
+      DO 1520 I=1,LONK
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)*
+     +             ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) )
+           FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV))
+           FXX(I,JV)=ALF3(I)*TXX(I,JV)
+           FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV))
+           FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV))
+           FXY(I,JV)=ALFQ(I)*TXY(I,JV)
+           FXZ(I,JV)=ALFQ(I)*TXZ(I,JV)
+           FYY(I,JV)=ALF (I)*TYY(I,JV)
+           FYZ(I,JV)=ALF (I)*TYZ(I,JV)
+           FZZ(I,JV)=ALF (I)*TZZ(I,JV)
+C
+           T0 (I,JV)=T0(I,JV)-F0(I,JV)
+           TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV))
+           TXX(I,JV)=ALF4(I)*TXX(I,JV)
+           TY (I,JV)=TY (I,JV)-FY (I,JV)
+           TZ (I,JV)=TZ (I,JV)-FZ (I,JV)
+           TYY(I,JV)=TYY(I,JV)-FYY(I,JV)
+           TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV)
+           TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV)
+           TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+           TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+C
+         ENDIF
+C
+ 1520 CONTINUE
+ 152  CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 160 I=1,LONK
+         IF(UEXT(I).LT.0.) THEN
+           TM(I)=TM(I)+FM(I)
+           ALF(I)=FM(I)/TM(I)
+         ENDIF
+ 160  CONTINUE
+C
+      DO 161 I=1,LONK-1
+         IF(UEXT(I).GE.0.) THEN
+           TM(I+1)=TM(I+1)+FM(I)
+           ALF(I)=FM(I)/TM(I+1)
+         ENDIF
+ 161  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        TM(1)=TM(1)+FM(I)
+        ALF(I)=FM(I)/TM(1)
+      ENDIF
+C
+      DO 162 I=1,LONK
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF1(I)-ALF(I)
+         ALF3(I)=ALF(I)*ALF1(I)
+ 162  CONTINUE
+C
+      DO 170 JV=1,NTRA
+      DO 1700 I=1,LONK
+C
+         IF(UEXT(I).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV)
+           T0 (I,JV)=T0(I,JV)+F0(I,JV)
+           TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV)
+     +          +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM )
+           TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM
+           TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV)
+     +          +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV))
+           TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV)
+     +          +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV))
+           TY (I,JV)=TY (I,JV)+FY (I,JV)
+           TZ (I,JV)=TZ (I,JV)+FZ (I,JV)
+           TYY(I,JV)=TYY(I,JV)+FYY(I,JV)
+           TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV)
+           TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV)
+C
+         ENDIF
+C
+ 1700 CONTINUE
+ 170  CONTINUE
+C
+      DO 171 JV=1,NTRA
+      DO 1710 I=1,LONK-1
+C
+         IF(UEXT(I).GE.0.) THEN
+C
+           TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV)
+           T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV)
+           TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV)
+     +           +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+           TX (I+1,JV)=ALF(I)*FX (I  ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM
+           TXY(I+1,JV)=ALF(I)*FXY(I  ,JV)+ALF1(I)*TXY(I+1,JV)
+     +            +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I  ,JV))
+           TXZ(I+1,JV)=ALF(I)*FXZ(I  ,JV)+ALF1(I)*TXZ(I+1,JV)
+     +            +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I  ,JV))
+           TY (I+1,JV)=TY (I+1,JV)+FY (I,JV)
+           TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV)
+           TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV)
+           TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV)
+           TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV)
+C
+         ENDIF
+C
+ 1710 CONTINUE
+ 171  CONTINUE
+C
+      I=LONK
+      IF(UEXT(I).GE.0.) THEN
+        DO 172 JV=1,NTRA
+           TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV)
+           T0 (1,JV)=T0(1,JV)+F0(I,JV)
+           TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV)
+     +         +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM )
+           TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM
+           TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV)
+     +          +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV))
+           TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV)
+     +          +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV))
+           TY (1,JV)=TY (1,JV)+FY (I,JV)
+           TZ (1,JV)=TZ (1,JV)+FZ (I,JV)
+           TYY(1,JV)=TYY(1,JV)+FYY(I,JV)
+           TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV)
+           TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV)
+ 172    CONTINUE
+      ENDIF
+C
+C  retour aux mailles d'origine (passage des Tij aux Sij)
+C
+      IF(NUMK.GT.1) THEN
+C
+      DO 18 I2=1,NUMK
+C
+         DO 180 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            SM(I3,K,L)=SMNEW(I3)
+            ALF(I)=SMNEW(I3)/TM(I)
+            TM(I)=TM(I)-SMNEW(I3)
+C
+            ALFQ(I)=ALF(I)*ALF(I)
+            ALF1(I)=1.-ALF(I)
+            ALF1Q(I)=ALF1(I)*ALF1(I)
+            ALF2(I)=ALF1(I)-ALF(I)
+            ALF3(I)=ALF(I)*ALFQ(I)
+            ALF4(I)=ALF1(I)*ALF1Q(I)
+C
+ 180     CONTINUE
+C
+         DO 181 JV=1,NTRA
+         DO 181 I=1,LONK
+C
+            I3=I2+(I-1)*NUMK
+            S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)*
+     +              ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) )
+            SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV))
+            SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV)
+            SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV))
+            SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV))
+            SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV)
+            SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV)
+            SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV)
+            SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV)
+            SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV)
+C
+C   reajusts moments remaining in the box
+C
+            T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV)
+            TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV))
+            TXX(I,JV)=ALF4 (I)*TXX(I,JV)
+            TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV)
+            TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV)
+            TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV)
+            TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV)
+            TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV)
+            TXY(I,JV)=ALF1Q(I)*TXY(I,JV)
+            TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV)
+C
+ 181     CONTINUE
+C
+ 18   CONTINUE
+C
+      ELSE
+C
+      DO 190 I=1,LON
+         SM(I,K,L)=TM(I)
+ 190  CONTINUE
+      DO 191 JV=1,NTRA
+      DO 1910 I=1,LON
+         S0 (I,K,L,JV)=T0 (I,JV)
+         SSX (I,K,L,JV)=TX (I,JV)
+         SY (I,K,L,JV)=TY (I,JV)
+         SZ (I,K,L,JV)=TZ (I,JV)
+         SSXX(I,K,L,JV)=TXX(I,JV)
+         SSXY(I,K,L,JV)=TXY(I,JV)
+         SSXZ(I,K,L,JV)=TXZ(I,JV)
+         SYY(I,K,L,JV)=TYY(I,JV)
+         SYZ(I,K,L,JV)=TYZ(I,JV)
+         SZZ(I,K,L,JV)=TZZ(I,JV)
+ 1910 CONTINUE
+ 191  CONTINUE
+C
+      ENDIF
+C
+ 1    CONTINUE
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+
+c      DO 9999 l = 1, llm
+c      DO 9999 j = 1, jjp1
+c      DO 9999 i = 1, iip1
+c	   IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN
+c           PRINT*, '-------------------'
+c	        PRINT*, 'En fin de ADVXP'
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c	        print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra)
+c           print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra)
+c       	print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra)
+c            WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP'
+c            STOP
+c           ENDIF
+c 9999 CONTINUE
+c ---------- bouclage cyclique
+
+      DO l = 1,llm
+      DO j = 1,jjp1
+         SM(iip1,j,l) = SM(1,j,l)
+         S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+     	 SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+    	 SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+    	 SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+      END DO
+      END DO
+
+C ----------- qqtite totale de traceur dans tte l'atmosphere
+      DO l = 1, llm
+      DO j = 1, jjp1
+      DO i = 1, iim
+        sqf = sqf + S0(i,j,l,ntra)
+      END DO
+      END DO
+      END DO
+
+      PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----'
+      PRINT*,'sqf=',sqf
+c-------------------------------------------------------------
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advy.F	(revision 984)
@@ -0,0 +1,422 @@
+!
+! $Header$
+!
+      SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (SOM) advection of tracer in Y direction  C
+C                                                                C
+C  Source : Pascal Simon ( Meteo, CNRM )			 C
+C  Adaptation : A.A. (LGGE) 					 C
+C  Derniere Modif : 15/12/94 LAST
+C								 C
+C  sont les arguments d'entree pour le s-pg			 C
+C								 C
+C  argument de sortie du s-pg					 C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation 
+C
+C  parametres principaux du modele
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+ 
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,kp,l
+      INTEGER ntra
+      PARAMETER (ntra = 1)
+
+      REAL dty
+      REAL pbarv ( iip1,jjm, llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     +    ,sy(iip1,jjp1,llm,ntra)
+     +    ,sz(iip1,jjp1,llm,ntra)
+
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL VGRI(iip1,0:jjp1,llm)
+
+C  Rem : UGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en y uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+      REAL FZ(iim,jjm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+      REAL TEMPTM          ! Just temporal variable
+c
+C  Special pour poles 
+c
+      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
+      REAL sns0(ntra),snsz(ntra),snsm
+      REAL s1v(llm),slatv(llm)
+      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+      REAL cx1(llm,ntra), cxLAT(llm,ntra)
+      REAL cy1(llm,ntra), cyLAT(llm,ntra)
+      REAL z1(iim), zcos(iim), zsin(iim)
+      real smpn,smps,s0pn,s0ps
+      REAL SSUM
+      EXTERNAL SSUM
+C
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv=llm
+
+C
+C  the moments Fi are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+
+      DO l = 1,llm
+         DO j = 1,jjm
+            DO i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l)  
+            enddo
+         enddo
+         do i=1,iip1
+             vgri(i,0,l) = 0.
+             vgri(i,jjp1,l) = 0.
+         enddo
+      enddo
+
+      DO 1 L=1,NIV
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 11
+C
+      DO 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
+     +                           ABS(sy(I,K,L,JV))),sy(I,K,L,JV))
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+           FM(I,0)=-VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+           SM(I,1,L)=SM(I,1,L)-FM(I,0)
+           SM0=SM0+FM(I,0)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+C
+ 21   CONTINUE
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+C
+           F0(I,0,JV)=ALF(I,0)*
+     +               ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) )
+C
+           S00(JV)=S00(JV)+F0(I,0,JV)
+           S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+           sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV)
+           sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV)
+           sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV)
+C
+         ENDIF
+C
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+           SM(I,1,L)=SM(I,1,L)+FM(I,0)
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+         ENDIF
+C
+         ALF1(I,0)=1.-ALF(I,0)
+C
+ 25   CONTINUE
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+C
+         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+         S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+         sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM
+C
+         ENDIF
+C
+ 260  CONTINUE
+ 26   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+         ELSE
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+C
+ 300  CONTINUE
+ 30   CONTINUE
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+           F0(I,K,JV)=ALF (I,K)*
+     +                ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) )
+           FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV)
+           FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV)
+           FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV)
+C
+           S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+           sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV)
+           sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV)
+           sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV)
+C
+         ELSE
+C
+           F0(I,K,JV)=ALF (I,K)*
+     +               ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+           FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV)
+           FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV)
+           FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV)
+C
+           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV)
+           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV)
+           sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV)
+C
+         ENDIF
+C
+ 310  CONTINUE
+ 31   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ELSE
+           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+         ENDIF
+C
+         ALF1(I,K)=1.-ALF(I,K)
+C
+ 320  CONTINUE
+ 32   CONTINUE
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV)
+     +               +3.*TEMPTM
+         sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV)
+         sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV)
+C
+         ELSE
+C
+         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+         S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+         sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV)
+     +                +3.*TEMPTM
+         sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV)
+         sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV)
+C
+         ENDIF
+C
+ 330  CONTINUE
+ 33   CONTINUE
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+           SM0=SM0+FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+C
+ 41   CONTINUE
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           F0 (I,K,JV)=ALF(I,K)*
+     +                ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) )
+           S00(JV)=S00(JV)+F0(I,K,JV)
+C
+           S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV)
+           sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV)
+           sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV)
+         ENDIF
+C
+ 420  CONTINUE
+ 42   CONTINUE
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ENDIF
+C
+         ALF1(I,K)=1.-ALF(I,K)
+C
+ 45   CONTINUE
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM
+C
+         ENDIF
+C
+ 460  CONTINUE
+ 46   CONTINUE
+C
+ 1    CONTINUE
+C
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advyp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advyp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advyp.F	(revision 984)
@@ -0,0 +1,653 @@
+!
+! $Header$
+!
+      SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ
+     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+      IMPLICIT NONE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in Y direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  Source : Pascal Simon ( Meteo, CNRM )			 C
+C  Adaptation : A.A. (LGGE) 					 C
+C  Derniere Modif : 19/10/95 LAST
+C								 C
+C  sont les arguments d'entree pour le s-pg			 C
+C								 C
+C  argument de sortie du s-pg					 C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation 
+C
+C  parametres principaux du modele
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+ 
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,kp,l
+      INTEGER ntra
+C      PARAMETER (ntra = 1)
+
+      REAL dty
+      REAL pbarv ( iip1,jjm, llm )
+
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+     +    ,SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+C
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL VGRI(iip1,0:jjp1,llm)
+
+C  Rem : UGRI et WGRI ne sont pas utilises dans 
+C  cette subroutine ( advection en y uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+C  the moments Fij are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+C
+      REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1)
+      REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra)
+      REAL FZ(iim,jjm,ntra)
+      REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra)
+      REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra)
+      REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1)
+      REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1)
+      REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1)
+      REAL ALF4(iim,0:jjp1)
+      REAL TEMPTM          ! Just temporal variable
+      REAL SLPMAX,S1MAX,S1NEW,S2NEW
+c
+C  Special pour poles 
+c
+      REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn
+      REAL sns0(ntra),snsz(ntra),snsm
+      REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra)
+      REAL cx1(llm,ntra), cxLAT(llm,ntra)
+      REAL cy1(llm,ntra), cyLAT(llm,ntra)
+      REAL z1(iim), zcos(iim), zsin(iim)
+      REAL SSUM
+      EXTERNAL SSUM
+C
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv = llm         !       tab. S et VGRI 
+                    
+c-----------------------------------------------------------------
+C initialisations
+
+      sbms = 0.
+      sfms = 0.
+      sfzs = 0.
+      sbmn = 0.
+      sfmn = 0.
+      sfzn = 0.
+
+c-----------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+c 
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqi = sqi + S0(i,j,l,ntra)
+           END DO
+         END DO
+      END DO
+      PRINT*,'---------- DIAG DANS ADVY - ENTREE --------'
+      PRINT*,'sqi=',sqi
+
+c-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion des flux de masses en kg
+C-AA 20/10/94  le signe -1 est necessaire car indexation opposee
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjm
+            DO 500 i = 1,iip1  
+            vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l)
+  500 CONTINUE
+
+CAA Initialisation de flux fictifs aux bords sup. des boites pol.
+
+      DO l = 1,llm
+         DO i = 1,iip1  
+             vgri(i,0,l) = 0.
+             vgri(i,jjp1,l) = 0.
+         ENDDO
+      ENDDO
+c
+c----------------- START HERE -----------------------
+C  boucle sur les niveaux
+C
+      DO 1 L=1,NIV
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 11
+C
+      DO 10 JV=1,NTRA
+      DO 10 K=1,LAT
+      DO 100 I=1,LON
+         IF(S0(I,K,L,JV).GT.0.) THEN
+           SLPMAX=AMAX1(S0(I,K,L,JV),0.)
+           S1MAX=1.5*SLPMAX
+           S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV)))
+           S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                  AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) )
+           SY (I,K,L,JV)=S1NEW
+           SYY(I,K,L,JV)=S2NEW
+       SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV)))
+       SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+         ELSE
+           SY (I,K,L,JV)=0.
+           SYY(I,K,L,JV)=0.
+           SSXY(I,K,L,JV)=0.
+           SYZ(I,K,L,JV)=0.
+         ENDIF
+ 100  CONTINUE
+ 10   CONTINUE
+C
+ 11   CONTINUE
+C
+C  le flux a travers le pole Nord est traite separement
+C
+      SM0=0.
+      DO 20 JV=1,NTRA
+         S00(JV)=0.
+ 20   CONTINUE
+C
+      DO 21 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+           FM(I,0)=-VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+           SM(I,1,L)=SM(I,1,L)-FM(I,0)
+           SM0=SM0+FM(I,0)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+         ALF3(I,0)=ALF(I,0)*ALFQ(I,0)
+         ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0)
+C
+ 21   CONTINUE
+c     print*,'ADVYP 21'
+C
+      DO 22 JV=1,NTRA
+      DO 220 I=1,LON
+C
+         IF(VGRI(I,0,L).LE.0.) THEN
+C
+           F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)*
+     +        ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) )
+C
+           S00(JV)=S00(JV)+F0(I,0,JV)
+           S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV)
+           SY (I,1,L,JV)=ALF1Q(I,0)*
+     +            (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV))
+           SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV)
+           SSX (I,1,L,JV)=ALF1 (I,0)*
+     +            (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) )
+           SZ (I,1,L,JV)=ALF1 (I,0)*
+     +            (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) )
+           SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV)
+           SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV)
+           SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV)
+           SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV)
+           SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV)
+C
+         ENDIF
+C
+ 220  CONTINUE
+ 22   CONTINUE
+C
+      DO 23 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           FM(I,0)=VGRI(I,0,L)*DTY
+           ALF(I,0)=FM(I,0)/SM0
+         ENDIF
+ 23   CONTINUE
+C
+      DO 24 JV=1,NTRA
+      DO 240 I=1,LON
+         IF(VGRI(I,0,L).GT.0.) THEN
+           F0(I,0,JV)=ALF(I,0)*S00(JV)
+         ENDIF
+ 240  CONTINUE
+ 24   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+c     print*,'av ADVYP 25'
+      DO 25 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+           SM(I,1,L)=SM(I,1,L)+FM(I,0)
+           ALF(I,0)=FM(I,0)/SM(I,1,L)
+         ENDIF
+C
+         ALFQ(I,0)=ALF(I,0)*ALF(I,0)
+         ALF1(I,0)=1.-ALF(I,0)
+         ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0)
+         ALF2(I,0)=ALF1(I,0)-ALF(I,0)
+         ALF3(I,0)=ALF1(I,0)*ALF(I,0)
+C
+ 25   CONTINUE
+c     print*,'av ADVYP 25'
+C
+      DO 26 JV=1,NTRA
+      DO 260 I=1,LON
+C
+         IF(VGRI(I,0,L).GT.0.) THEN
+C
+         TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV)
+         S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV)
+         SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV)
+     +        +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM )
+         SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM
+      SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV)
+      SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV)
+C
+         ENDIF
+C
+ 260  CONTINUE
+ 26   CONTINUE
+C
+C  calculate flux and moments between adjacent boxes
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+C  flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0
+C
+c     print*,'av ADVYP 30'
+      DO 30 K=1,LAT-1
+      KP=K+1
+      DO 300 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+           SM(I,KP,L)=SM(I,KP,L)-FM(I,K)
+         ELSE
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+C
+ 300  CONTINUE
+ 30   CONTINUE
+c     print*,'ap ADVYP 30'
+C
+      DO 31 JV=1,NTRA
+      DO 31 K=1,LAT-1
+      KP=K+1
+      DO 310 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+           F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)*
+     +        ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) )
+           FY (I,K,JV)=ALFQ(I,K)*
+     +                 (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV))
+           FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV)
+           FX (I,K,JV)=ALF (I,K)*
+     +                 (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV))
+           FZ (I,K,JV)=ALF (I,K)*
+     +                 (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV))
+           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV)
+           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV)
+           FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV)
+           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV)
+           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV)
+C
+           S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV)
+           SY (I,KP,L,JV)=ALF1Q(I,K)*
+     +                 (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV))
+           SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV)
+           SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV)
+           SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV)
+           SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV)
+           SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV)
+           SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV)
+           SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV)
+           SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV)
+C
+         ELSE
+C
+           F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
+     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+           FY (I,K,JV)=ALFQ(I,K)*
+     +                 (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV))
+           FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV)
+      FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV))
+      FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV))
+           FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV)
+           FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV)
+           FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV)
+           FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV)
+           FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           SY (I,K,L,JV)=ALF1Q(I,K)*
+     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+           SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV)
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV)
+           SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV)
+           SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV)
+           SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV)
+           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+C
+         ENDIF
+C
+ 310  CONTINUE
+ 31   CONTINUE
+c     print*,'ap ADVYP 31'
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 32 K=1,LAT-1
+      KP=K+1
+      DO 320 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ELSE
+           SM(I,KP,L)=SM(I,KP,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,KP,L)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+C
+ 320  CONTINUE
+ 32   CONTINUE
+c     print*,'ap ADVYP 32'
+C
+      DO 33 JV=1,NTRA
+      DO 33 K=1,LAT-1
+      KP=K+1
+      DO 330 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+       SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV)
+     +  +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM )
+         SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV)
+     +            +3.*TEMPTM
+       SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV)
+     +         +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV))
+       SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV)
+     +         +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV))
+         SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV)
+         SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV)
+         SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV)
+         SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV)
+         SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV)
+C
+         ELSE
+C
+         TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV)
+         S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV)
+       SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV)
+     +  +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM )
+         SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV)
+     +                 +3.*TEMPTM
+       SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV)
+     +             +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV))
+         SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV)
+     +             +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV))
+         SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV)
+         SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV)
+         SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV)
+         SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV)
+         SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV)
+C
+         ENDIF
+C
+ 330  CONTINUE
+ 33   CONTINUE
+c     print*,'ap ADVYP 33'
+C
+C  traitement special pour le pole Sud (idem pole Nord)
+C
+      K=LAT
+C
+      SM0=0.
+      DO 40 JV=1,NTRA
+         S00(JV)=0.
+ 40   CONTINUE
+C
+      DO 41 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           FM(I,K)=VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,K)
+           SM0=SM0+FM(I,K)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF(I,K)*ALFQ(I,K)
+         ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K)
+C
+ 41   CONTINUE
+c     print*,'ap ADVYP 41'
+C
+      DO 42 JV=1,NTRA
+      DO 420 I=1,LON
+C
+         IF(VGRI(I,K,L).GE.0.) THEN
+           F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)*
+     +             ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) )
+           S00(JV)=S00(JV)+F0(I,K,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV)
+           SY (I,K,L,JV)=ALF1Q(I,K)*
+     +                  (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV))
+           SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV)
+      SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV))
+      SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV))
+           SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV)
+           SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV)
+           SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV)
+           SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV)
+         ENDIF
+C
+ 420  CONTINUE
+ 42   CONTINUE
+c     print*,'ap ADVYP 42'
+C
+      DO 43 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           FM(I,K)=-VGRI(I,K,L)*DTY
+           ALF(I,K)=FM(I,K)/SM0
+         ENDIF
+ 43   CONTINUE
+c     print*,'ap ADVYP 43'
+C
+      DO 44 JV=1,NTRA
+      DO 440 I=1,LON
+         IF(VGRI(I,K,L).LT.0.) THEN
+           F0(I,K,JV)=ALF(I,K)*S00(JV)
+         ENDIF
+ 440  CONTINUE
+ 44   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 45 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,K)
+           ALF(I,K)=FM(I,K)/SM(I,K,L)
+         ENDIF
+C
+         ALFQ(I,K)=ALF(I,K)*ALF(I,K)
+         ALF1(I,K)=1.-ALF(I,K)
+         ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K)
+         ALF2(I,K)=ALF1(I,K)-ALF(I,K)
+         ALF3(I,K)=ALF1(I,K)*ALF(I,K)
+C
+ 45   CONTINUE
+c     print*,'ap ADVYP 45'
+C
+      DO 46 JV=1,NTRA
+      DO 460 I=1,LON
+C
+         IF(VGRI(I,K,L).LT.0.) THEN
+C
+         TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV)
+         S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV)
+         SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV)
+     +           +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM )
+         SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM
+      SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV)
+      SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV)
+C
+         ENDIF
+C
+ 460  CONTINUE
+ 46   CONTINUE
+c     print*,'ap ADVYP 46'
+C
+ 1    CONTINUE
+
+c--------------------------------------------------
+C     bouclage cyclique horizontal .
+     
+      DO l = 1,llm
+         DO jv = 1,ntra
+            DO j = 1,jjp1
+               SM(iip1,j,l) = SM(1,j,l)
+               S0(iip1,j,l,jv) = S0(1,j,l,jv)
+               SSX(iip1,j,l,jv) = SSX(1,j,l,jv)   
+               SY(iip1,j,l,jv) = SY(1,j,l,jv)
+               SZ(iip1,j,l,jv) = SZ(1,j,l,jv)
+            END DO
+         END DO
+      END DO
+
+c -------------------------------------------------------------------
+C *** Test  negativite:
+
+c      DO jv = 1,ntra
+c       DO l = 1,llm
+c         DO j = 1,jjp1
+c           DO i = 1,iip1
+c              IF (s0( i,j,l,jv ).lt.0.) THEN
+c                 PRINT*, '------ S0 < 0 en FIN ADVYP ---'
+c                 PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv)
+cc                 STOP
+c              ENDIF
+c           ENDDO
+c         ENDDO
+c       ENDDO
+c      ENDDO
+ 
+   
+c -------------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+ 
+       DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqf = sqf + S0(i,j,l,ntra)
+           END DO
+         END DO
+       END DO
+      PRINT*,'---------- DIAG DANS ADVY - SORTIE --------'
+      PRINT*,'sqf=',sqf
+c     print*,'ap ADVYP fin'
+
+c-----------------------------------------------------------------
+C
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advz.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advz.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advz.F	(revision 984)
@@ -0,0 +1,320 @@
+!
+! $Header$
+!
+      SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz)
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                C
+C  first-order moments (FOM) advection of tracer in Z direction  C
+C                                                                C
+C  Source : Pascal Simon (Meteo,CNRM)                            C
+C  Adaptation : A.Armengaud (LGGE) juin 94                       C
+C                                                                C
+C                                                                C
+C  sont des arguments d'entree pour le s-pg...                   C
+C                                                                C
+C  dq est l'argument de sortie pour le s-pg                      C
+C								 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+C    #include "traceur.h"
+
+C  Arguments :
+C  -----------
+C  dtz : frequence fictive d'appel du transport 
+C  w : flux de masse en z en Pa.m2.s-1
+
+      INTEGER ntra
+      PARAMETER (ntra = 1)
+
+      REAL dtz
+      REAL w ( iip1,jjp1,llm )
+    
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL sx(iip1,jjp1,llm,ntra)
+     +    ,sy(iip1,jjp1,llm,ntra)
+     +    ,sz(iip1,jjp1,llm,ntra)
+
+
+C  Local :
+C  ------- 
+
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+
+      REAL WGRI(iip1,jjp1,0:llm)
+
+C
+C  the moments F are used as temporary  storage for 
+C  portions of grid boxes in transit at the current latitude
+C
+      REAL FM(iim,llm)
+      REAL F0(iim,llm,ntra),FX(iim,llm,ntra)
+      REAL FY(iim,llm,ntra),FZ(iim,llm,ntra)
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim)
+      REAL TEMPTM            ! Just temporal variable
+      REAL sqi,sqf
+C
+      LOGICAL LIMIT
+      INTEGER lon,lat,niv
+      INTEGER i,j,jv,k,l,lp
+
+      lon = iim
+      lat = jjp1
+      niv = llm 
+
+C *** Test de passage d'arguments ******
+ 
+c     DO 399 l = 1, llm
+c     DO 399 j = 1, jjp1
+c     DO 399 i = 1, iip1
+c        IF (S0(i,j,l,ntra) .lt. 0. ) THEN
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c           print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c           print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c           print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c           PRINT*, 'AIE !! debut ADVZ - pbl arg. passage dans ADVZ'
+c            STOP
+c        ENDIF
+  399 CONTINUE
+
+C-----------------------------------------------------------------
+C *** Test : diag de la qqtite totale de traceur 
+C            dans l'atmosphere avant l'advection en z
+      sqi = 0.
+      sqf = 0.
+
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+               sqi = sqi + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------'
+      PRINT*,'sqi=',sqi
+
+C-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion du flux de masse en kg.s-1
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+c            wgri (i,j,llm+1-l) =  w (i,j,l) / g 
+               wgri (i,j,llm+1-l) =  w (i,j,l) 
+c             wgri (i,j,0) = 0.                ! a detruire ult.
+c             wgri (i,j,l) = 0.1               !    w (i,j,l) 
+c             wgri (i,j,llm) = 0.              ! a detruire ult.
+  500 CONTINUE
+         DO  j = 1,jjp1
+            DO i = 1,iip1  
+               wgri(i,j,0)=0.
+            enddo
+         enddo
+
+C-----------------------------------------------------------------
+  
+C  start here          
+C  boucle sur les latitudes
+C
+      DO 1 K=1,LAT
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 101
+C
+      DO 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.),
+     +                              ABS(sz(I,K,L,JV))),sz(I,K,L,JV))
+ 100     CONTINUE
+ 10   CONTINUE
+C
+ 101  CONTINUE
+C
+C  boucle sur les niveaux intercouches de 1 a NIV-1
+C   (flux nul au sommet L=0 et a la base L=NIV)
+C
+C  calculate flux and moments between adjacent boxes
+C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+      DO 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           FM(I,L)=-WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+         ELSE
+           FM(I,L)=WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,L)
+         ENDIF
+C
+         ALFQ (I)=ALF(I)*ALF(I)
+         ALF1 (I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           F0(I,L,JV)=ALF (I)*( S0(I,K,LP,JV)-ALF1(I)*sz(I,K,LP,JV) )
+           FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV)
+           FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV)
+           FY(I,L,JV)=ALF (I)*sy(I,K,LP,JV)
+C
+           S0(I,K,LP,JV)=S0(I,K,LP,JV)-F0(I,L,JV)
+           sz(I,K,LP,JV)=ALF1Q(I)*sz(I,K,LP,JV)
+           sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV)
+           sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV)
+C
+         ELSE
+C
+           F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) )
+           FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV)
+           FX(I,L,JV)=ALF (I)*sx(I,K,L,JV)
+           FY(I,L,JV)=ALF (I)*sy(I,K,L,JV)
+C
+           S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,L,JV)
+           sz(I,K,L,JV)=ALF1Q(I)*sz(I,K,L,JV)
+           sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV)
+           sy(I,K,L,JV)=sy(I,K,L,JV)-FY(I,L,JV)
+C
+         ENDIF
+C
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,L)
+         ELSE
+           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+         ENDIF
+C
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+C
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+           S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+           sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM
+           sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV)
+           sy(I,K,L,JV)=sy(I,K,L,JV)+FY(I,L,JV)
+C
+         ELSE
+C
+           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+           S0(I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+           sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV)
+     +                  +3.*TEMPTM
+           sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV)
+           sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(I,L,JV)
+C
+         ENDIF
+C
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+C
+C-------------------------------------------------------------
+C
+C ----------- AA Test en fin de ADVX ------ Controle des S*
+
+c     DO 9999 l = 1, llm
+c     DO 9999 j = 1, jjp1
+c     DO 9999 i = 1, iip1
+c        IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN 
+c           PRINT*, '-------------------'
+c           PRINT*, 'En fin de ADVZ'
+c           PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra)
+c           print*, 'sx(',i,j,l,')=',sx(i,j,l,ntra)
+c           print*, 'sy(',i,j,l,')=',sy(i,j,l,ntra)
+c           print*, 'sz(',i,j,l,')=',sz(i,j,l,ntra)
+c           WRITE (*,*) 'On arrete !! - pbl en fin de ADVZ1'
+c            STOP
+c        ENDIF
+ 9999 CONTINUE
+
+C *** ------------------- bouclage cyclique  en X ------------
+      
+c      DO l = 1,llm
+c         DO j = 1,jjp1
+c            SM(iip1,j,l) = SM(1,j,l)
+c            S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+C            sx(iip1,j,l,ntra) = sx(1,j,l,ntra)
+c            sy(iip1,j,l,ntra) = sy(1,j,l,ntra)
+c            sz(iip1,j,l,ntra) = sz(1,j,l,ntra)
+c         ENDDO
+c      ENDDO
+           
+C-------------------------------------------------------------
+C *** Test : diag de la qqtite totale de traceur 
+C            dans l'atmosphere avant l'advection en z
+      DO l = 1,llm
+         DO j = 1,jjp1
+            DO i = 1,iim
+               sqf = sqf + S0(i,j,l,ntra)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+      PRINT*,'sqf=', sqf
+
+C-------------------------------------------------------------
+      RETURN
+      END
+C_______________________________________________________________
+C_______________________________________________________________
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/advzp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/advzp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/advzp.F	(revision 984)
@@ -0,0 +1,378 @@
+!
+! $Header$
+!
+      SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ
+     .                 ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra )
+
+      IMPLICIT NONE
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  second-order moments (SOM) advection of tracer in Z direction  C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C                                                                 C
+C  Source : Pascal Simon ( Meteo, CNRM )                          C
+C  Adaptation : A.A. (LGGE)                                       C
+C  Derniere Modif : 19/11/95 LAST                                 C
+C                                                                 C
+C  sont les arguments d'entree pour le s-pg                       C
+C                                                                 C
+C  argument de sortie du s-pg                                     C
+C                                                                 C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Rem : Probleme aux poles il faut reecrire ce cas specifique
+C        Attention au sens de l'indexation
+C
+
+C
+C  parametres principaux du modele
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+C
+C  Arguments :
+C  ----------
+C  dty : frequence fictive d'appel du transport
+C  parbu,pbarv : flux de masse en x et y en Pa.m2.s-1
+c
+        INTEGER lon,lat,niv
+        INTEGER i,j,jv,k,kp,l,lp
+        INTEGER ntra
+c        PARAMETER (ntra = 1)
+c
+        REAL dtz
+        REAL w ( iip1,jjp1,llm )
+c
+C  moments: SM  total mass in each grid box
+C           S0  mass of tracer in each grid box
+C           Si  1rst order moment in i direction
+C
+      REAL SM(iip1,jjp1,llm)
+     +    ,S0(iip1,jjp1,llm,ntra)
+      REAL SSX(iip1,jjp1,llm,ntra)
+     +    ,SY(iip1,jjp1,llm,ntra)
+     +    ,SZ(iip1,jjp1,llm,ntra)
+     +    ,SSXX(iip1,jjp1,llm,ntra)
+     +    ,SSXY(iip1,jjp1,llm,ntra)
+     +    ,SSXZ(iip1,jjp1,llm,ntra)
+     +    ,SYY(iip1,jjp1,llm,ntra)
+     +    ,SYZ(iip1,jjp1,llm,ntra)
+     +    ,SZZ(iip1,jjp1,llm,ntra)
+C
+C  Local :
+C  -------
+C
+C  mass fluxes across the boundaries (UGRI,VGRI,WGRI)
+C  mass fluxes in kg
+C  declaration :
+C
+      REAL WGRI(iip1,jjp1,0:llm)
+
+C Rem : UGRI et VGRI ne sont pas utilises dans
+C  cette subroutine ( advection en z uniquement )
+C  Rem 2 :le dimensionnement de VGRI depend de celui de pbarv
+C         attention a celui de WGRI
+C
+C  the moments F are similarly defined and used as temporary
+C  storage for portions of the grid boxes in transit
+C
+C  the moments Fij are used as temporary storage for
+C  portions of the grid boxes in transit at the current level
+C
+C  work arrays
+C
+C
+      REAL F0(iim,llm,ntra),FM(iim,llm)
+      REAL FX(iim,llm,ntra),FY(iim,llm,ntra)
+      REAL FZ(iim,llm,ntra)
+      REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra)
+      REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra)
+      REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra)
+      REAL S00(ntra)
+      REAL SM0             ! Just temporal variable
+C
+C  work arrays
+C
+      REAL ALF(iim),ALF1(iim)
+      REAL ALFQ(iim),ALF1Q(iim)
+      REAL ALF2(iim),ALF3(iim)
+      REAL ALF4(iim)
+      REAL TEMPTM          ! Just temporal variable
+      REAL SLPMAX,S1MAX,S1NEW,S2NEW
+c
+      REAL sqi,sqf
+      LOGICAL LIMIT
+
+      lon = iim         ! rem : Il est possible qu'un pbl. arrive ici
+      lat = jjp1        ! a cause des dim. differentes entre les
+      niv = llm         !       tab. S et VGRI 
+                    
+c-----------------------------------------------------------------
+C *** Test : diag de la qtite totale de traceur dans
+C            l'atmosphere avant l'advection en Y
+c 
+      sqi = 0.
+      sqf = 0.
+c
+      DO l = 1,llm
+         DO j = 1,jjp1
+           DO i = 1,iim
+              sqi = sqi + S0(i,j,l,ntra)
+           END DO
+         END DO
+      END DO
+      PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------'
+      PRINT*,'sqi=',sqi
+
+c-----------------------------------------------------------------
+C  Interface : adaptation nouveau modele
+C  -------------------------------------
+C
+C  Conversion des flux de masses en kg
+
+      DO 500 l = 1,llm
+         DO 500 j = 1,jjp1
+            DO 500 i = 1,iip1  
+            wgri (i,j,llm+1-l) = w (i,j,l)  
+  500 CONTINUE
+      do j=1,jjp1
+         do i=1,iip1
+            wgri(i,j,0)=0.
+         enddo
+      enddo
+c
+cAA rem : Je ne suis pas sur du signe  
+cAA       Je ne suis pas sur pour le 0:llm
+c
+c-----------------------------------------------------------------
+C---------------------- START HERE -------------------------------
+C
+C  boucle sur les latitudes
+C
+      DO 1 K=1,LAT
+C
+C  place limits on appropriate moments before transport
+C      (if flux-limiting is to be applied)
+C
+      IF(.NOT.LIMIT) GO TO 101
+C
+      DO 10 JV=1,NTRA
+      DO 10 L=1,NIV
+         DO 100 I=1,LON
+            IF(S0(I,K,L,JV).GT.0.) THEN
+              SLPMAX=S0(I,K,L,JV)
+              S1MAX =1.5*SLPMAX
+              S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV)))
+              S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. ,
+     +                     AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) )
+              SZ (I,K,L,JV)=S1NEW
+              SZZ(I,K,L,JV)=S2NEW
+              SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV)))
+              SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV)))
+            ELSE
+              SZ (I,K,L,JV)=0.
+              SZZ(I,K,L,JV)=0.
+              SSXZ(I,K,L,JV)=0.
+              SYZ(I,K,L,JV)=0.
+            ENDIF
+ 100     CONTINUE
+ 10   CONTINUE
+C
+ 101  CONTINUE
+C
+C  boucle sur les niveaux intercouches de 1 a NIV-1
+C   (flux nul au sommet L=0 et a la base L=NIV)
+C
+C  calculate flux and moments between adjacent boxes
+C     (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0)
+C  1- create temporary moments/masses for partial boxes in transit
+C  2- reajusts moments remaining in the box
+C
+      DO 11 L=1,NIV-1
+      LP=L+1
+C
+      DO 110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           FM(I,L)=-WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+           SM(I,K,LP)=SM(I,K,LP)-FM(I,L)
+         ELSE
+           FM(I,L)=WGRI(I,K,L)*DTZ
+           ALF(I)=FM(I,L)/SM(I,K,L)
+           SM(I,K,L)=SM(I,K,L)-FM(I,L)
+         ENDIF
+C
+         ALFQ (I)=ALF(I)*ALF(I)
+         ALF1 (I)=1.-ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2 (I)=ALF1(I)-ALF(I)
+         ALF3 (I)=ALF(I)*ALFQ(I)
+         ALF4 (I)=ALF1(I)*ALF1Q(I)
+C
+ 110  CONTINUE
+C
+      DO 111 JV=1,NTRA
+      DO 1110 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)*
+     +          ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) )
+           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV))
+           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV)
+           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV)
+           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV)
+           FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV))
+           FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV))
+           FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV)
+           FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV)
+           FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV)
+C
+           S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV)
+           SZ (I,K,LP,JV)=ALF1Q(I)
+     +                   *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV))
+           SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV)
+           SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV)
+           SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV)
+           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV)
+           SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV)
+           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV)
+           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV)
+           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV)
+C
+         ELSE
+C
+           F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV)
+     +           +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) )
+           FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV))
+           FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV)
+           FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV)
+           FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV)
+           FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV))
+           FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV))
+           FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV)
+           FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV)
+           FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV)
+C
+           S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV)
+           SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV))
+           SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV)
+           SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV)
+           SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV)
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV)
+           SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV)
+           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV)
+           SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV)
+C
+         ENDIF
+C
+ 1110 CONTINUE
+ 111  CONTINUE
+C
+ 11   CONTINUE
+C
+C  puts the temporary moments Fi into appropriate neighboring boxes
+C
+      DO 12 L=1,NIV-1
+      LP=L+1
+C
+      DO 120 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+           SM(I,K,L)=SM(I,K,L)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,L)
+         ELSE
+           SM(I,K,LP)=SM(I,K,LP)+FM(I,L)
+           ALF(I)=FM(I,L)/SM(I,K,LP)
+         ENDIF
+C
+         ALF1(I)=1.-ALF(I)
+         ALFQ(I)=ALF(I)*ALF(I)
+         ALF1Q(I)=ALF1(I)*ALF1(I)
+         ALF2(I)=ALF(I)*ALF1(I)
+         ALF3(I)=ALF1(I)-ALF(I)
+C
+ 120  CONTINUE
+C
+      DO 121 JV=1,NTRA
+      DO 1210 I=1,LON
+C
+         IF(WGRI(I,K,L).LT.0.) THEN
+C
+           TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV)
+           S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV)
+           SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV)
+     +        +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM )
+           SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV)
+     +                  +3.*TEMPTM
+           SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV)
+     +              +3.*(ALF1(I)*FX (I,L,JV)-ALF  (I)*SSX (I,K,L,JV))
+           SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV)
+     +              +3.*(ALF1(I)*FY (I,L,JV)-ALF  (I)*SY (I,K,L,JV))
+           SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV)
+           SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV)
+           SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV)
+           SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV)
+           SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV)
+C
+         ELSE
+C
+           TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV)
+           S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV)
+           SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV)
+     +        +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM )
+           SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV)
+     +                   +3.*TEMPTM
+           SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV)
+     +                   +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV))
+           SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV)
+     +                   +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV))
+           SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV)
+           SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV)
+           SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV)
+           SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV)
+           SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV)
+C
+         ENDIF
+C
+ 1210 CONTINUE
+ 121  CONTINUE
+C
+ 12   CONTINUE
+C
+C  fin de la boucle principale sur les latitudes
+C
+ 1    CONTINUE
+C
+      DO l = 1,llm
+      DO j = 1,jjp1
+          SM(iip1,j,l) = SM(1,j,l)
+	  S0(iip1,j,l,ntra) = S0(1,j,l,ntra)
+          SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra)
+	  SY(iip1,j,l,ntra) = SY(1,j,l,ntra)
+          SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra)
+      ENDDO
+      ENDDO
+c										C-------------------------------------------------------------
+C *** Test : diag de la qqtite totale de tarceur
+C            dans l'atmosphere avant l'advection en z
+       DO l = 1,llm
+       DO j = 1,jjp1
+       DO i = 1,iim
+          sqf = sqf + S0(i,j,l,ntra)
+       ENDDO
+       ENDDO
+       ENDDO
+       PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------'
+       PRINT*,'sqf=', sqf
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/bands.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/bands.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/bands.F90	(revision 984)
@@ -0,0 +1,425 @@
+  module Bands
+  
+    integer, parameter :: bands_caldyn=1
+    integer, parameter :: bands_vanleer=2
+    integer, parameter :: bands_dissip=3
+    
+    INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2
+    INTEGER,dimension(:),allocatable :: jj_Nb_dissip
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis
+    INTEGER,dimension(:),allocatable :: distrib_phys
+  
+  contains
+  
+  subroutine AllocateBands
+    use parallel
+    implicit none
+    
+    allocate(jj_Nb_Caldyn(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer2(0:MPI_Size-1))
+    allocate(jj_Nb_dissip(0:MPI_Size-1))
+    allocate(jj_Nb_physic(0:MPI_Size-1))
+    allocate(jj_Nb_physic_bis(0:MPI_Size-1))
+    allocate(distrib_phys(0:MPI_Size-1))
+  
+  end subroutine AllocateBands
+  
+  subroutine Read_distrib
+    use parallel
+    implicit none
+
+    include "dimensions.h"
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+    
+      call AllocateBands
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+       
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+      
+         do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_caldyn(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_vanleer(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_dissip(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,distrib_phys(i)
+        enddo
+	
+	CLOSE(unit_number)  
+  
+      else
+        do i=0,mpi_size-1
+          jj_nb_caldyn(i)=(jjm+1)/mpi_size
+	  if (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
+        enddo
+      
+        jj_nb_vanleer(:)=jj_nb_caldyn(:)
+        jj_nb_dissip(:)=jj_nb_caldyn(:)
+        
+	do i=0,mpi_size-1
+	  distrib_phys(i)=(iim*(jjm-1)+2)/mpi_size
+	  IF (i<MOD(iim*(jjm-1)+2,mpi_size)) distrib_phys(i)=distrib_phys(i)+1
+	enddo
+      endif
+  
+   end subroutine Read_distrib
+   
+   
+   SUBROUTINE  Set_Bands 
+     USE parallel
+     USE mod_phys_lmdz_para, ONLY : jj_para_begin,jj_para_end
+     IMPLICIT NONE
+     INCLUDE 'dimensions.h'    
+     INTEGER :: i
+        
+      do i=0,mpi_size-1
+         jj_nb_vanleer2(i)=(jjm+1)/mpi_size
+	 if (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
+      enddo
+          
+      do i=0,MPI_Size-1
+        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic(i-1)=jj_Nb_physic(i-1)-1
+          endif
+        endif
+      enddo
+      
+      do i=0,MPI_Size-1
+        jj_Nb_physic_bis(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+          else
+	    jj_Nb_physic_bis(i-1)=jj_Nb_physic_bis(i-1)+1
+	    jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+	  endif
+        endif
+      enddo
+      
+    end subroutine Set_Bands
+
+
+    subroutine AdjustBands_caldyn
+      use times
+      use parallel
+      implicit none
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+        if (jj_nb_caldyn(max_proc)>3) then
+          if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then
+             jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+             jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
+	        -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then
+               jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+               jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+         
+    end subroutine AdjustBands_caldyn
+    
+    subroutine AdjustBands_vanleer
+      use times
+      use parallel
+      implicit none
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_vanleer(max_proc)>3) then
+          if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. &
+             timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then
+             jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+             jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then
+               jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+               jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+         
+    end subroutine AdjustBands_vanleer
+
+    subroutine AdjustBands_dissip
+      use times
+      use parallel
+      implicit none
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_dissip(max_proc)>3) then
+          if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then
+             jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+             jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
+	        - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then
+               jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+               jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+         
+    end subroutine AdjustBands_dissip
+
+    subroutine AdjustBands_physic
+      use times
+      USE mod_phys_lmdz_para, only : klon_mpi_para_nb
+      USE parallel
+      implicit none
+
+      integer :: i,Index
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: Inc
+      real :: medium
+      integer :: NbTot,sgn
+      
+      allocate(value(0:mpi_size-1))
+      allocate(Inc(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+      
+      medium=0
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_physic(i),timer_physic,i)
+	medium=medium+value(i)
+      enddo    
+      
+      medium=medium/mpi_size      
+      NbTot=0
+      do i=0,mpi_size-1
+        Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i))
+        NbTot=NbTot+Inc(i)  
+      enddo
+      
+      if (NbTot>=0) then
+        Sgn=1
+      else
+        Sgn=-1
+	NbTot=-NbTot
+      endif
+      
+      Index=0
+      do i=1,NbTot
+        Inc(Index)=Inc(Index)-Sgn
+	Index=Index+1
+	if (Index>mpi_size-1) Index=0
+      enddo
+      
+      do i=0,mpi_size-1
+        distrib_phys(i)=klon_mpi_para_nb(i)+inc(i)
+      enddo
+     
+    end subroutine AdjustBands_physic
+
+    subroutine WriteBands
+    USE parallel
+    implicit none
+    include "dimensions.h"
+
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+  
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+      
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+        
+!	write (unit_number,*) '*** Bandes caldyn ***'
+	do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_caldyn(i)
+        enddo
+        
+!	write (unit_number,*) '*** Bandes vanleer ***' 
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_vanleer(i)
+        enddo
+       
+!        write (unit_number,*) '*** Bandes dissip ***'
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_dissip(i)
+        enddo
+        
+	do i=0,mpi_size-1
+          write (unit_number,*) i,distrib_phys(i)
+        enddo
+	
+        CLOSE(unit_number)   
+      else 
+        print *,'probleme lors de l ecriture des bandes'
+      endif
+       
+    end subroutine WriteBands
+  
+  end module Bands
+  
+  
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/bernoui.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/bernoui.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/bernoui.F	(revision 984)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c     calcul de la fonction de Bernouilli aux niveaux s  .....
+c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
+c                              energ.cinet.)
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Decalrations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+c
+c   Arguments:
+c   ----------
+c
+      INTEGER nlay,ngrid
+      REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay)
+c
+c   Local:
+c   ------
+c
+      INTEGER   ijl
+c
+c-----------------------------------------------------------------------
+c   calcul de Bernouilli:
+c   ---------------------
+c
+      DO 4 ijl = 1,ngrid*nlay
+         pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
+   4  CONTINUE
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+      CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/bernoui_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/bernoui_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/bernoui_p.F	(revision 984)
@@ -0,0 +1,74 @@
+      SUBROUTINE bernoui_p (ngrid,nlay,pphi,pecin,pbern)
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c     calcul de la fonction de Bernouilli aux niveaux s  .....
+c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
+c                              energ.cinet.)
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Decalrations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+c
+c   Arguments:
+c   ----------
+c
+      INTEGER nlay,ngrid
+      REAL pphi(ngrid,nlay),pecin(ngrid,nlay),pbern(ngrid,nlay)
+c
+c   Local:
+c   ------
+c
+      INTEGER   ij,l,ijb,ije,jjb,jje
+c
+c-----------------------------------------------------------------------
+c   calcul de Bernouilli:
+c   ---------------------
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if (pole_sud) ije=ij_end
+
+      jjb=jj_begin
+      jje=jj_end+1
+      if (pole_sud) jje=jj_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)                
+      DO l=1,llm
+    
+        DO 4 ij = ijb,ije
+          pbern( ij,l ) =  pphi( ij,l ) + pecin( ij,l )
+   4    CONTINUE
+       
+       ENDDO
+c$OMP END DO NOWAIT
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+
+        
+        CALL filtreg_p( pbern,jjb,jje, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/bilan_dyn_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/bilan_dyn_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/bilan_dyn_p.F	(revision 984)
@@ -0,0 +1,633 @@
+!
+! $Header$
+!
+      SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum,
+     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+c   AFAIRE
+c   Prevoir en champ nq+1 le diagnostique de l'energie
+c   en faisant Qzon=Cv T + L * ...
+c             vQ..A=Cp T + L * ...
+
+      USE IOIPSL
+      USE parallel
+      USE mod_hallo
+      use misc_mod
+      use write_field
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "temps.h"
+#include "iniprint.h"
+
+c====================================================================
+c
+c   Sous-programme consacre à des diagnostics dynamiques de base
+c
+c 
+c   De facon generale, les moyennes des scalaires Q sont ponderees par
+c   la masse.
+c
+c   Les flux de masse sont eux simplement moyennes.
+c
+c====================================================================
+
+c   Arguments :
+c   ===========
+
+      integer ntrac
+      real dt_app,dt_cum
+      real ps(iip1,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+      real flux_u(iip1,jjp1,llm)
+      real flux_v(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+      real phi(iip1,jjp1,llm)
+      real ucov(iip1,jjp1,llm)
+      real vcov(iip1,jjm,llm)
+      real trac(iip1,jjp1,llm,ntrac)
+
+c   Local :
+c   =======
+
+      integer icum,ncum
+      logical first
+      real zz,zqy,zfactv(jjm,llm)
+
+      integer nQ
+      parameter (nQ=7)
+
+
+cym      character*6 nom(nQ)
+cym      character*6 unites(nQ)
+      character*6,save :: nom(nQ)
+      character*6,save :: unites(nQ)
+
+      character*10 file
+      integer ifile
+      parameter (ifile=4)
+
+      integer itemp,igeop,iecin,iang,iu,iovap,iun
+      integer i_sortie
+
+      save first,icum,ncum
+      save itemp,igeop,iecin,iang,iu,iovap,iun
+      save i_sortie
+
+      real time
+      integer itau
+      save time,itau
+      data time,itau/0.,0/
+
+      data first/.true./
+      data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
+      data i_sortie/1/
+
+      real ww
+
+c   variables dynamiques intermédiaires
+      REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+      REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL vorpot(iip1,jjm,llm)
+      REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
+      REAL bern(iip1,jjp1,llm)
+
+c   champ contenant les scalaires advectés.
+      real Q(iip1,jjp1,llm,nQ)
+    
+c   champs cumulés
+      real ps_cum(iip1,jjp1)
+      real masse_cum(iip1,jjp1,llm)
+      real flux_u_cum(iip1,jjp1,llm)
+      real flux_v_cum(iip1,jjm,llm)
+      real Q_cum(iip1,jjp1,llm,nQ)
+      real flux_uQ_cum(iip1,jjp1,llm,nQ)
+      real flux_vQ_cum(iip1,jjm,llm,nQ)
+      real flux_wQ_cum(iip1,jjp1,llm,nQ)
+      real dQ(iip1,jjp1,llm,nQ)
+
+      save ps_cum,masse_cum,flux_u_cum,flux_v_cum
+      save Q_cum,flux_uQ_cum,flux_vQ_cum
+
+c   champs de tansport en moyenne zonale
+      integer ntr,itr
+      parameter (ntr=5)
+
+cym      character*10 znom(ntr,nQ)
+cym      character*20 znoml(ntr,nQ)
+cym      character*10 zunites(ntr,nQ)
+      character*10,save :: znom(ntr,nQ)
+      character*20,save :: znoml(ntr,nQ)
+      character*10,save :: zunites(ntr,nQ)
+
+      integer iave,itot,immc,itrs,istn
+      data iave,itot,immc,itrs,istn/1,2,3,4,5/
+      character*3 ctrs(ntr)
+      data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+      real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+      real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+      real zmasse(jjm,llm),zamasse(jjm)
+
+      real zv(jjm,llm),psi(jjm,llm+1)
+
+      integer i,j,l,iQ
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      character*10 infile
+
+      integer fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      integer ndex3d(jjm*llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer ii,jj
+      integer zan, dayref
+C
+      real rlong(jjm),rlatg(jjm)
+      integer :: jjb,jje,jjn,ijb,ije
+      type(Request) :: Req
+
+
+c=====================================================================
+c   Initialisation
+c=====================================================================
+      ndex3d=0
+      if (adjust) return
+      
+      time=time+dt_app
+      itau=itau+1
+
+      if (first) then
+
+
+        icum=0
+c       initialisation des fichiers
+        first=.false.
+c   ncum est la frequence de stokage en pas de temps
+        ncum=dt_cum/dt_app
+        if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+           WRITE(lunout,*)
+     .            'Pb : le pas de cumule doit etre multiple du pas'
+           WRITE(lunout,*)'dt_app=',dt_app
+           WRITE(lunout,*)'dt_cum=',dt_cum
+           stop
+        endif
+
+        if (i_sortie.eq.1) then
+	 file='dynzon'
+         if (mpi_rank==0) then
+	 call inigrads(ifile,1
+     s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dt_cum,file,'dyn_zon ')
+         endif
+        endif
+
+        nom(itemp)='T'
+        nom(igeop)='gz'
+        nom(iecin)='K'
+        nom(iang)='ang'
+        nom(iu)='u'
+        nom(iovap)='ovap'
+        nom(iun)='un'
+
+        unites(itemp)='K'
+        unites(igeop)='m2/s2'
+        unites(iecin)='m2/s2'
+        unites(iang)='ang'
+        unites(iu)='m/s'
+        unites(iovap)='kg/kg'
+        unites(iun)='un'
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      infile='dynzon'
+
+      zan = annee_ref
+      dayref = day_ref
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      rlong=0.
+      rlatg=rlatv*180./pi
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jjn=jj_nb-1
+       
+      call histbeg(trim(infile)//'_'//trim(int2str(mpi_rank)),
+     .             1, rlong(jjb:jje), jjn, rlatg(jjb:jje),
+     .             1, 1, 1, jjn,
+     .             tau0, zjulian, dt_cum, thoriid, fileid)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
+     .              llm, presnivs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+      do iQ=1,nQ
+         do itr=1,ntr
+            if(itr.eq.1) then
+               znom(itr,iQ)=nom(iQ)
+               znoml(itr,iQ)=nom(iQ)
+               zunites(itr,iQ)=unites(iQ)
+            else
+               znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+               znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+               zunites(itr,iQ)='m/s * '//unites(iQ)
+            endif
+         enddo
+      enddo
+
+c   Declarations des champs avec dimension verticale
+c      print*,'1HISTDEF'
+      do iQ=1,nQ
+         do itr=1,ntr
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'var ',itr,iQ
+     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+            call histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+c   Declarations pour les fonctions de courant
+c      print*,'2HISTDEF'
+          call histdef(fileid,'psi'//nom(iQ)
+     .      ,'stream fn. '//znoml(itot,iQ),
+     .      zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+      enddo
+
+
+c   Declarations pour les champs de transport d'air
+c      print*,'3HISTDEF'
+      call histdef(fileid, 'masse', 'masse',
+     .             'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'v', 'v',
+     .             'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+c   Declarations pour les fonctions de courant
+c      print*,'4HISTDEF'
+          call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
+     .      1,jjn,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+
+
+c   Declaration des champs 1D de transport en latitude
+c      print*,'5HISTDEF'
+      do iQ=1,nQ
+         do itr=2,ntr
+            call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+      enddo
+
+
+c      print*,'8HISTDEF'
+               CALL histend(fileid)
+
+
+      endif
+
+
+c=====================================================================
+c   Calcul des champs dynamiques
+c   ----------------------------
+
+      jjb=jj_begin
+      jje=jj_end
+    
+c   énergie cinétique
+      ucont(:,jjb:jje,:)=0
+
+      call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Req)
+      call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Req)
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      CALL covcont_p(llm,ucov,vcov,ucont,vcont)
+      CALL enercin_p(vcov,ucov,vcont,ucont,ecin)
+
+c   moment cinétique
+      do l=1,llm
+         ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
+         unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
+      enddo
+
+      Q(:,jjb:jje,:,itemp)=teta(:,jjb:jje,:)*pk(:,jjb:jje,:)/cpp
+      Q(:,jjb:jje,:,igeop)=phi(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iecin)=ecin(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iang)=ang(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iu)=unat(:,jjb:jje,:)
+      Q(:,jjb:jje,:,iovap)=trac(:,jjb:jje,:,1)
+      Q(:,jjb:jje,:,iun)=1.
+
+
+c=====================================================================
+c   Cumul
+c=====================================================================
+c
+      if(icum.EQ.0) then
+         ps_cum=0.
+         masse_cum=0.
+         flux_u_cum=0.
+         flux_v_cum=0.
+         Q_cum=0.
+         flux_vQ_cum=0.
+         flux_uQ_cum=0.
+      endif
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+      icum=icum+1
+
+c   accumulation des flux de masse horizontaux
+      ps_cum=ps_cum+ps
+      masse_cum=masse_cum+masse
+      flux_u_cum=flux_u_cum+flux_u
+      flux_v_cum=flux_v_cum+flux_v
+      do iQ=1,nQ
+        Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ)
+     .                       +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:)
+      enddo
+
+c=====================================================================
+c  FLUX ET TENDANCES
+c=====================================================================
+
+c   Flux longitudinal
+c   -----------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=jjb,jje
+               do i=1,iim
+                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
+     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+               enddo
+               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+            enddo
+         enddo
+      enddo
+
+c    flux méridien
+c    -------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=jjb,jje
+               do i=1,iip1
+                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
+     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+               enddo
+            enddo
+         enddo
+      enddo
+
+
+c    tendances
+c    ---------
+
+c   convergence horizontale
+      call Register_Hallo(flux_uQ_cum,ip1jmp1,llm,2,2,2,2,Req)
+      call Register_Hallo(flux_vQ_cum,ip1jm,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      call  convflu_p(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+c   calcul de la vitesse verticale
+      call Register_Hallo(flux_u_cum,ip1jmp1,llm,2,2,2,2,Req)
+      call Register_Hallo(flux_v_cum,ip1jm,llm,2,2,2,2,Req)
+      call SendRequest(Req)
+      call WaitRequest(Req)
+
+      call convmas_p(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert_p(convm,w)
+
+      do iQ=1,nQ
+         do l=1,llm-1
+            do j=jjb,jje
+               do i=1,iip1
+                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+               enddo
+            enddo
+         enddo
+      enddo
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+c=====================================================================
+c   PAS DE TEMPS D'ECRITURE
+c=====================================================================
+      if (icum.eq.ncum) then
+c=====================================================================
+
+      IF (prt_level > 5)
+     . WRITE(lunout,*)'Pas d ecriture'
+
+c   Normalisation
+      do iQ=1,nQ
+         Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ)
+     .	                      /masse_cum(:,jjb:jje,:)
+      enddo
+      zz=1./float(ncum)
+      ps_cum=ps_cum*zz
+      masse_cum=masse_cum*zz
+      flux_u_cum=flux_u_cum*zz
+      flux_v_cum=flux_v_cum*zz
+      flux_uQ_cum=flux_uQ_cum*zz
+      flux_vQ_cum=flux_vQ_cum*zz
+      dQ=dQ*zz
+
+
+c   A retravailler eventuellement
+c   division de dQ par la masse pour revenir aux bonnes grandeurs
+      do iQ=1,nQ
+         dQ(:,jjb:jje,:,iQ)=dQ(:,jjb:jje,:,iQ)/masse_cum(:,jjb:jje,:)
+      enddo
+ 
+c=====================================================================
+c   Transport méridien
+c=====================================================================
+
+c   cumul zonal des masses des mailles
+c   ----------------------------------
+      zv=0.
+      zmasse=0.
+      call massbar(masse_cum,massebx,masseby)
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      
+      do l=1,llm
+         do j=jjb,jje
+            do i=1,iim
+               zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+               zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+            enddo
+            zfactv(j,l)=cv(1,j)/zmasse(j,l)
+         enddo
+      enddo
+
+c     print*,'3OK'
+c   --------------------------------------------------------------
+c   calcul de la moyenne zonale du transport :
+c   ------------------------------------------
+c
+c                                     --
+c TOT : la circulation totale       [ vq ]
+c
+c                                      -     -
+c MMC : mean meridional circulation [ v ] [ q ]
+c
+c                                     ----      --       - -
+c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+c
+c                                     - * - *       - -       -     -
+c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+c
+c                                              - -
+c    on utilise aussi l'intermediaire TMP :  [ v q ]
+c
+c    la variable zfactv transforme un transport meridien cumule
+c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+c
+c   --------------------------------------------------------------
+
+
+c   ----------------------------------------
+c   Transport dans le plan latitude-altitude
+c   ----------------------------------------
+
+      zvQ=0.
+      psiQ=0.
+      do iQ=1,nQ
+         zvQtmp=0.
+         do l=1,llm
+            do j=jjb,jje
+c              print*,'j,l,iQ=',j,l,iQ
+c   Calcul des moyennes zonales du transort total et de zvQtmp
+               do i=1,iim
+                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
+     s                            +flux_vQ_cum(i,j,l,iQ)
+                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
+     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
+     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+               enddo
+c              print*,'aOK'
+c   Decomposition
+               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+            enddo
+         enddo
+c   fonction de courant meridienne pour la quantite Q
+         do l=llm,1,-1
+            do j=jjb,jje
+               psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+            enddo
+         enddo
+      enddo
+
+c   fonction de courant pour la circulation meridienne moyenne
+      psi=0.
+      do l=llm,1,-1
+         do j=jjb,jje
+            psi(j,l)=psi(j,l+1)+zv(j,l)
+            zv(j,l)=zv(j,l)*zfactv(j,l)
+         enddo
+      enddo
+
+c     print*,'4OK'
+c   sorties proprement dites
+      if (i_sortie.eq.1) then
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jje=jj_end-1
+      if (pole_sud) jjn=jj_nb-1
+      
+      do iQ=1,nQ
+         do itr=1,ntr
+            call histwrite(fileid,znom(itr,iQ),itau,
+     s                     zvQ(jjb:jje,:,itr,iQ)
+     s                     ,jjn*llm,ndex3d)
+         enddo
+         call histwrite(fileid,'psi'//nom(iQ),
+     s                  itau,psiQ(jjb:jje,1:llm,iQ)
+     s                  ,jjn*llm,ndex3d)
+      enddo
+
+      call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1)
+     s   ,jjn*llm,ndex3d)
+      call histwrite(fileid,'v',itau,zv(jjb:jje,1)
+     s   ,jjn*llm,ndex3d)
+      psi=psi*1.e-9
+      call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm),
+     s               jjn*llm,ndex3d)
+
+      endif
+
+
+c   -----------------
+c   Moyenne verticale
+c   -----------------
+
+      zamasse=0.
+      do l=1,llm
+         zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
+      enddo
+      zavQ=0.
+      do iQ=1,nQ
+         do itr=2,ntr
+            do l=1,llm
+               zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)
+     s                             +zvQ(jjb:jje,l,itr,iQ)
+     s                             *zmasse(jjb:jje,l)
+            enddo
+            zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
+            call histwrite(fileid,'a'//znom(itr,iQ),itau,
+     s                     zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
+         enddo
+      enddo
+
+c     on doit pouvoir tracer systematiquement la fonction de courant.
+
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/caladvtrac_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/caladvtrac_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/caladvtrac_p.F	(revision 984)
@@ -0,0 +1,134 @@
+!
+! $Header$
+!
+c
+c
+            SUBROUTINE caladvtrac_p(q,pbaru,pbarv ,
+     *                   p ,masse, dq ,  teta,
+     *                   flxw, pk, iapptrac)
+      USE parallel
+c
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron  
+c
+c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+c=======================================================================
+c
+c       Shema de  Van Leer
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "control.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqmx),dq( ip1jmp1,llm,2 )
+      REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm)
+      REAL               :: flxw(ip1jmp1,llm)
+
+      integer ijb,ije,jjb,jje
+
+c  ..................................................................
+c
+c  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
+c
+c  ..................................................................
+c
+c   Local:
+c   ------
+
+      INTEGER ij,l, iq, iapptrac
+      REAL finmasse(ip1jmp1,llm), dtvrtrac
+      
+
+cc
+c
+C initialisation
+cym      ijb=ij_begin
+cym      ije=ij_end
+
+      
+cym      dq(ijb:ije,1:llm,1:2)=q(ijb:ije,1:llm,1:2)
+
+c  test des valeurs minmax
+cc        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
+cc        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
+
+c   advection
+c      print *,'appel a advtrac'
+
+      CALL advtrac_p( pbaru,pbarv, 
+     *             p,  masse,q,iapptrac, teta,
+     .             flxw, pk)
+
+         goto 9999
+         IF( iapptrac.EQ.iapp_tracvl ) THEN
+c
+cc          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
+cc          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
+
+cc     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
+c
+          DO l = 1, llm
+           DO ij = ijb, ije
+             finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+           ENDDO
+          ENDDO
+
+          CALL qminimum_p( q, 2, finmasse )
+
+cym   --> le reste ne set a rien
+          goto 9999
+	  
+c          CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
+          finmasse(ijb:ije,:)=masse(ijb:ije,:)         
+          
+          jjb=jj_begin
+          jje=jj_end
+          CALL filtreg_p ( finmasse ,jjb,jje,  jjp1,  llm, 
+     *                     -2, 2, .TRUE., 1 )
+c
+c   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
+c   ********************************************************************
+c
+          dtvrtrac = iapp_tracvl * dtvr
+c
+           DO iq = 1 , 2
+            DO l = 1 , llm
+             DO ij = ijb,ije
+             dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l)
+     *                               /  dtvrtrac
+             ENDDO
+            ENDDO
+           ENDDO
+c
+         ELSE
+cym   --> le reste ne set a rien
+          goto 9999
+	  
+           DO iq = 1 , 2
+           DO l  = 1, llm
+             DO ij = ijb,ije
+              dq(ij,l,iq)  = 0.
+             ENDDO
+           ENDDO
+           ENDDO
+
+         ENDIF
+c
+
+
+c  ... On appelle  qminimum uniquement  pour l'eau vapeur et liquide  ..
+
+ 
+ 9999 RETURN
+      END
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/caldyn_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/caldyn_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/caldyn_p.F	(revision 984)
@@ -0,0 +1,191 @@
+!
+! $Header$
+!
+c
+c
+#undef DEBUG_IO
+c#define DEBUG_IO
+
+      SUBROUTINE caldyn_p
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+      USE parallel
+      USE Write_Field_p
+      
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      LOGICAL conser
+
+      INTEGER itau
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm)
+      REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL w(ip1jmp1,llm)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      REAL,SAVE :: ang(ip1jmp1,llm)
+      REAL,SAVE :: p(ip1jmp1,llmp1)
+      REAL,SAVE :: massebx(ip1jmp1,llm),masseby(ip1jm,llm)
+      REAL,SAVE :: psexbarxy(ip1jm)
+      REAL,SAVE :: vorpot(ip1jm,llm)
+      REAL,SAVE :: ecin(ip1jmp1,llm)
+      REAL,SAVE :: bern(ip1jmp1,llm)
+      REAL,SAVE :: massebxy(ip1jm,llm)
+      REAL,SAVE :: convm(ip1jmp1,llm)
+      INTEGER   ij,l,ijb,ije,ierr
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+      CALL covcont_p  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL pression_p ( ip1jmp1, ap      , bp   ,  ps  , p            )
+cym      CALL psextbar (   ps   , psexbarxy                          )
+c$OMP BARRIER
+      CALL massdair_p (    p   , masse                                )
+      CALL massbar_p  (   masse, massebx , masseby                    )
+      call massbarxy_p(   masse, massebxy                             )
+      CALL flumass_p  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      CALL dteta1_p   (   teta , pbaru   , pbarv, dteta               )
+      CALL convmas1_p  (   pbaru, pbarv   , convm                      )
+c$OMP BARRIER      
+      CALL convmas2_p  (   convm                      )
+c$OMP BARRIER
+#ifdef DEBUG_IO
+c$OMP BARRIER
+c$OMP MASTER
+      call WriteField_p('ucont',reshape(ucont,(/iip1,jmp1,llm/)))
+      call WriteField_p('vcont',reshape(vcont,(/iip1,jjm,llm/)))
+      call WriteField_p('p',reshape(p,(/iip1,jmp1,llmp1/)))
+      call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
+      call WriteField_p('massebx',reshape(massebx,(/iip1,jmp1,llm/)))
+      call WriteField_p('masseby',reshape(masseby,(/iip1,jjm,llm/)))
+      call WriteField_p('massebxy',reshape(massebxy,(/iip1,jjm,llm/)))
+      call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
+      call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
+      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
+      call WriteField_p('convm',reshape(convm,(/iip1,jmp1,llm/)))
+c$OMP END MASTER
+c$OMP BARRIER
+#endif      
+
+c$OMP BARRIER
+c$OMP MASTER
+      ijb=ij_begin
+      ije=ij_end
+            
+      DO ij =ijb, ije
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+c$OMP FLUSH
+      CALL vitvert_p ( convm  , w                                  )
+      CALL tourpot_p ( vcov   , ucov  , massebxy  , vorpot         )
+      CALL dudv1_p   ( vorpot , pbaru , pbarv     , du     , dv    )
+
+#ifdef DEBUG_IO      
+c$OMP BARRIER
+c$OMP MASTER
+      call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/)))
+      call WriteField_p('vorpot',reshape(vorpot,(/iip1,jjm,llm/)))
+      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
+      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
+c$OMP END MASTER
+c$OMP BARRIER
+#endif      
+      CALL enercin_p ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL bernoui_p ( ip1jmp1, llm   , phi       , ecin   , bern  )
+      CALL dudv2_p   ( teta   , pkf   , bern      , du     , dv    )
+
+#ifdef DEBUG_IO
+c$OMP BARRIER
+c$OMP MASTER
+      call WriteField_p('ecin',reshape(ecin,(/iip1,jmp1,llm/)))
+      call WriteField_p('bern',reshape(bern,(/iip1,jmp1,llm/)))
+      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
+      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
+      call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
+c$OMP END MASTER
+c$OMP BARRIER
+#endif
+      
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud) ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+         DO ij=ijb,ije
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO
+
+      CALL advect_new_p(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) 
+
+C  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi 
+C          probablement. Observe sur le code compile avec pgf90 3.0-1 
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l = 1, llm
+         DO ij = ijb, ije, iip1
+           IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+c         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',  
+c    ,   ' dans caldyn'
+c         PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+          dv(ij+iim,l) = dv(ij,l)
+          endif
+         enddo
+      enddo
+c$OMP END DO NOWAIT      
+c-----------------------------------------------------------------------
+c   Sorties eventuelles des variables de controle:
+c   ----------------------------------------------
+
+      IF( conser )  THEN
+c ym ---> exige communication collective ( aussi dans advect)
+        CALL sortvarc
+     $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+      ENDIF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/calfis_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/calfis_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/calfis_p.F	(revision 984)
@@ -0,0 +1,1084 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE calfis_p(nq,
+     $                  lafin,
+     $                  rdayvrai,
+     $                  heure,
+     $                  pucov,
+     $                  pvcov,
+     $                  pteta,
+     $                  pq,
+     $                  pmasse,
+     $                  pps,
+     $                  pp,
+     $                  ppk,
+     $                  pphis,
+     $                  pphi,
+     $                  pducov,
+     $                  pdvcov,
+     $                  pdteta,
+     $                  pdq,
+     $                  flxw,
+     $                  clesphy0,
+     $                  pdufi,
+     $                  pdvfi,
+     $                  pdhfi,
+     $                  pdqfi,
+     $                  pdpsfi)
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+      USE dimphy
+      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root 
+      USE parallel, ONLY : omp_chunk
+      USE mod_interface_dyn_phys
+      USE Write_Field
+      Use Write_field_p
+      USE Times
+      USE IOPHY
+      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"
+#include "advtrac.h"
+
+      INTEGER ngridmx,nq
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+      include 'mpif.h'
+
+c    Arguments :
+c    -----------
+      LOGICAL  lafin
+      REAL heure
+
+      REAL pvcov(iip1,jjm,llm)
+      REAL pucov(iip1,jjp1,llm)
+      REAL pteta(iip1,jjp1,llm)
+      REAL pmasse(iip1,jjp1,llm)
+      REAL pq(iip1,jjp1,llm,nqmx)
+      REAL pphis(iip1,jjp1)
+      REAL pphi(iip1,jjp1,llm)
+c
+      REAL pdvcov(iip1,jjm,llm)
+      REAL pducov(iip1,jjp1,llm)
+      REAL pdteta(iip1,jjp1,llm)
+      REAL pdq(iip1,jjp1,llm,nqmx)
+c
+      REAL pps(iip1,jjp1)
+      REAL pp(iip1,jjp1,llmp1)
+      REAL ppk(iip1,jjp1,llm)
+c
+      REAL pdvfi(iip1,jjm,llm)
+      REAL pdufi(iip1,jjp1,llm)
+      REAL pdhfi(iip1,jjp1,llm)
+      REAL pdqfi(iip1,jjp1,llm,nqmx)
+      REAL pdpsfi(iip1,jjp1)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+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
+c      REAL,ALLOCATABLE,SAVE :: pvervel(:,:)
+c
+      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
+      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
+      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
+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(:,:,:)
+c      REAL,ALLOCATABLE,SAVE :: pvervel_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(:)
+
+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,pvervel_omp,zdufi_omp,zdvfi_omp,
+c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_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
+cIM diagnostique PVteta, Amip2
+      INTEGER ntetaSTD
+      PARAMETER(ntetaSTD=3)
+      REAL rtetaSTD(ntetaSTD)
+      DATA rtetaSTD/350., 380., 405./
+      REAL PVteta(klon,ntetaSTD)
+      
+      REAL flxw(iip1,jjp1,llm)  ! Flux de masse verticale sur la grille dynamique
+      REAL flxwfi(klon,llm)     ! Flux de masse verticale sur la grille physiq
+      
+      REAL SSUM
+
+      LOGICAL firstcal, debut
+      DATA firstcal/.true./
+      SAVE firstcal,debut
+c$OMP THREADPRIVATE(firstcal,debut)
+      REAL rdayvrai
+      
+      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
+      INTEGER :: ierr
+      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
+      INTEGER, dimension(4) :: Req
+      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
+      integer :: k,kstart,kend
+      INTEGER :: offset  
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+      klon=klon_mpi
+      
+      PVteta(:,:)=0.
+            
+      IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         PRINT*,'STOP dans calfis'
+         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         PRINT*,'  ngridmx  jjm   iim   '
+         PRINT*,ngridmx,jjm,iim
+         STOP
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   latitude, longitude et aires des mailles pour la physique:
+c   ----------------------------------------------------------
+
+c
+      IF ( firstcal )  THEN
+          debut = .TRUE.
+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,nqmx))
+      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
+      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
+c      ALLOCATE(pvervel(klon,llm))
+      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
+      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqmx))
+      ALLOCATE(zdpsrf(klon))
+      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,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             
+      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
+        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
+
+        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
+c          pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
+        enddo
+
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   43.bis traceurs
+c   ---------------
+c
+
+      DO iq=1,nq
+         iiq=niadv(iq)
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+           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   convergence dynamique pour les traceurs "EAU"
+
+      DO iq=1,2
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+         DO l=1,llm
+           do ig0=1,klon
+             i=index_i(ig0)
+             j=index_j(ig0)
+c             pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
+           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)
+
+c$OMP MASTER
+      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
+c$OMP END MASTER
+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   ....  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_p.F  
+c
+cc$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+c      DO l=1,llm
+c        do ig0=1,klon
+c           i=index_i(ig0)
+c           j=index_j(ig0)
+c           pvervel(ig0,l) = pw(i,j,l)*g* unsaire(i,j)
+c        enddo
+c	if (is_north_pole) pvervel(1,l)=pw(1,1,l)*g /apoln
+c	if (is_south_pole) pvervel(klon,l)=pw(1,jjp1,l)*g/apols
+c      ENDDO
+cc$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
+        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) )
+c            pcvgu(ig0,l)= 0.5*(  pducov(iim,j,l)/cu(iim,j) 
+c     $                         + pducov(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) )
+c            pcvgu(ig0,l)= 0.5*(  pducov(i-1,j,l)/cu(i-1,j) 
+c     $                        + pducov(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
+        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) )
+    
+c          pcvgv(ig0+i,l)= 0.5 * (  pdvcov(i,j-1,l)/cv(i,j-1) 
+c     $                           + pdvcov(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)
+c           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)
+c              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)
+c              zcosbis(i)= COS(rlonv(i))*z1bis(i)
+              zsin(i)   = SIN(rlonv(i))*z1(i)
+c              zsinbis(i)= SIN(rlonv(i))*z1bis(i)
+           ENDDO
+  
+           zufi(1,l)  = SSUM(iim,zcos,1)/pi
+c           pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
+           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+c           pcvgv(1,l) = SSUM(iim,zsinbis,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)
+c         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)
+c           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)
+c              zcosbis(i) = COS(rlonv(i))*z1bis(i)
+              zsin(i)    = SIN(rlonv(i))*z1(i)
+c              zsinbis(i) = SIN(rlonv(i))*z1bis(i)
+	   ENDDO
+  
+           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
+c           pcvgu(klon,l) = SSUM(iim,zcosbis,1)/pi
+           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
+c           pcvgv(klon,l) = SSUM(iim,zsinbis,1)/pi
+
+        ENDDO
+c$OMP END DO NOWAIT       
+      endif
+
+
+      IF (is_sequential) THEN
+c
+cIM calcul PV a teta=350, 380, 405K
+        CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
+     $           ztfi,zplay,zplev,
+     $           ntetaSTD,rtetaSTD,PVteta)
+c
+      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   ---------------------
+
+cc$OMP  PARALLEL DEFAULT(NONE) 
+cc$OMP+ PRIVATE(i,l,offset,iq)
+cc$OMP+ SHARED(klon_omp_nb,nq,klon_omp_begin,
+cc$OMP+        debut,lafin,rdayvrai,heure,dtphys,zplev,zplay,
+cc$OMP+        zphi,zphis,presnivs,clesphy0,zufi,zvfi,ztfi,
+cc$OMP+        zqfi,pvervel,zdufi,zdvfi,zdtfi,zdqfi,zdpsrf)
+
+c PRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
+c c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
+c c$OMP+                 zqfi_omp,pvervel_omp,zdufi_omp,zdvfi_omp,
+c c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp)
+
+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,nq))
+c        allocate(pvervel_omp(klon,llm))
+        allocate(zdufi_omp(klon,llm))
+        allocate(zdvfi_omp(klon,llm))
+        allocate(zdtfi_omp(klon,llm))
+        allocate(zdqfi_omp(klon,llm,nq))
+        allocate(zdpsrf_omp(klon))
+	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,nq
+        do l=1,llm
+          do i=1,klon
+            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+c      do l=1,llm
+c        do i=1,klon
+c	  pvervel_omp(i,l)=pvervel(offset+i,l)
+c	enddo 
+c      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,nq
+        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 
+      
+c$OMP BARRIER
+cym      call WriteField_phy_p('zdtfi_omp',zdtfi_omp(:,:),llm)
+      
+      CALL physiq (klon,
+     .             llm,
+     .             nq,
+     .             debut,
+     .             lafin,
+     .             rdayvrai,
+     .             heure,
+     .             dtphys,
+     .             zplev_omp,
+     .             zplay_omp,
+     .             zphi_omp,
+     .             zphis_omp,
+     .             presnivs_omp,
+     .             clesphy0,
+     .             zufi_omp,
+     .             zvfi_omp,
+     .             ztfi_omp,
+     .             zqfi_omp,
+c     .             pvervel_omp,
+c#ifdef INCA
+     .             flxwfi,
+c#endif
+     .             zdufi_omp,
+     .             zdvfi_omp,
+     .             zdtfi_omp,
+     .             zdqfi_omp,
+     .             zdpsrf_omp,
+cIM diagnostique PVteta, Amip2          
+     .             pducov,
+     .             PVteta)
+
+cym      call WriteField_phy_p('zdtfi_omp',zdtfi_omp(:,:),llm)
+
+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,nq
+        do l=1,llm
+          do i=1,klon
+            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
+	  enddo
+	enddo 
+      enddo
+	
+c      do l=1,llm
+c        do i=1,klon
+c	  pvervel(offset+i,l)=pvervel_omp(i,l)
+c	enddo 
+c      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,nq
+        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 
+      
+
+cc$OMP END PARALLEL
+      klon=klon_mpi
+500   CONTINUE
+c$OMP BARRIER
+
+c$OMP MASTER
+cym      call WriteField_phy('zdtfi',zdtfi(:,:),llm)
+      call stop_timer(timer_physic)
+c$OMP END MASTER
+      
+      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
+c$OMP MASTER
+        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)
+c$OMP END MASTER
+c$OMP BARRIER
+     
+      endif
+   
+      if (MPI_rank<MPI_Size-1) then
+c$OMP BARRIER
+c$OMP MASTER      
+        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)
+c$OMP END MASTER
+c$OMP BARRIER     
+      endif
+
+c$OMP BARRIER
+c$OMP MASTER    
+      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
+c$OMP END MASTER
+c$OMP BARRIER     
+
+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  -----------------------------------
+c$OMP MASTER
+      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
+c$OMP END MASTER
+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 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   ---------------------
+
+      DO iq=1,nqmx
+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
+
+      DO iq=1,nq
+         iiq=niadv(iq)
+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,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 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 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.
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/clesph0.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/clesph0.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/clesph0.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+c..include clesph0.h
+c
+       COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr ,
+     ,                ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con
+c
+       LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/coefpoly.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/coefpoly.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/coefpoly.F	(revision 984)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 ,
+     ,                                          a0,a1,a2,a3         )
+      IMPLICIT NONE
+c
+c   ...  Auteur :   P. Le Van  ...
+c
+c
+c    Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui
+c      satisfait aux 4 equations  suivantes :
+
+c    a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1
+c    a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2
+c               a1  +     2.*a2*xtild1 +     3.*a3*xtild1*xtild1 = Xprim1
+c               a1  +     2.*a2*xtild2 +     3.*a3*xtild2*xtild2 = Xprim2
+
+c  On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3
+
+      REAL*8 Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi 
+      REAL*8 Xfout, Xprim
+      REAL*8 a1,a2,a3,a0, 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
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/com_io_dyn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/com_io_dyn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/com_io_dyn.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      integer histid, histvid, histaveid
+      common/com_io_dyn/histid, histvid, histaveid
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comconst.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comconst.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comconst.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comconst.h
+
+      COMMON/comconst/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl,
+     * dtvr,daysec,
+     * pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr,daysec
+      REAL pi,dtphys,dtdiss,rad,r,cpp,kappa
+      REAL cotot,unsim,g,omeg
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdiss.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdiss.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdiss.h	(revision 984)
@@ -0,0 +1,15 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'comdiss.h'
+
+      INTEGER niter
+      REAL tetau(llm),tetah(llm),cdivu,cdivh,crot
+      LOGICAL dissipst
+
+      COMMON/comdissi/niter
+      COMMON/comdissr/tetau,tetah,cdivu,cdivh,crot
+      COMMON/comdissl/dissipst
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissip.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissip.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissip.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE dissip.h
+
+      COMMON/comdissip/
+     $    lstardis,niterdis,coefdis,tetavel,tetatemp,gamdissip
+
+
+      LOGICAL lstardis
+      INTEGER niterdis
+
+      REAL tetavel,tetatemp,coefdis,gamdissip
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissipn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissipn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissipn.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comdissipn.h
+
+      REAL  tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
+c
+      COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm)   ,
+     1                        cdivu,      crot,         cdivh
+
+c
+c    Les parametres de ce common proviennent des calculs effectues dans 
+c             Inidissip  .
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissnew.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissnew.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comdissnew.h	(revision 984)
@@ -0,0 +1,18 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE comdissnew.h
+
+      COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv,
+     1                   tetagrot,tetatemp,coefdis 
+
+      LOGICAL lstardis
+      INTEGER nitergdiv, nitergrot, niterh
+      REAL     tetagdiv, tetagrot,  tetatemp, coefdis
+
+c
+c ... Les parametres de ce common comdissnew sont  lues par defrun_new 
+c              sur le fichier  run.def    ....
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comgeom.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comgeom.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comgeom.h	(revision 984)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+*CDK comgeom
+      COMMON/comgeom/
+     1 cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),
+     2 aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),
+     3 airev(ip1jm),unsaire(ip1jmp1),apoln,apols,
+     4 unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),
+     5 aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),
+     6 aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),
+     7 alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),
+     8 alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),
+     9 fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),
+     1 rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),
+     1 cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),
+     2 cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),
+     3 cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),
+     4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,
+     5 unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),
+     6 aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+c
+        REAL 
+     1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,
+     2 apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,
+     3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2 
+     6 ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,
+     7 aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu
+     8 , xprimv
+c
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comgeom2.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comgeom2.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comgeom2.h	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+*CDK comgeom2
+      COMMON/comgeom/
+     1 cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm)  ,
+     2 aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1)           ,
+     3 airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols                 ,  
+     4 unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm)       ,
+     5 aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1)       ,
+     6 aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1)         ,
+     7 alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1)        ,
+     8 alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1)    ,
+     9 fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm),
+     1 rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm)  ,
+     1 cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1)                        ,
+     2 cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1),
+     3 cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) ,
+     4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2                ,
+     5 unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1)                  ,
+     6 unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm)
+     7 , xprimu(iip1),xprimv(iip1)
+
+c
+      REAL 
+     1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire
+     2 ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4     ,
+     3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1           , 
+     6 unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2     ,
+     7 unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu    ,
+     8 cusurcvu,xprimu,xprimv
+c
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/comvert.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/comvert.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/comvert.h	(revision 984)
@@ -0,0 +1,12 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c   INCLUDE 'comvert.h'
+
+      COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm) ,
+     ,               pa,preff,nivsigs(llm),nivsig(llm+1)
+
+      REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_dat2d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_dat2d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_dat2d.F	(revision 984)
@@ -0,0 +1,221 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd ,
+     ,                           interbar                        )
+c
+c     Auteur :  P. Le Van
+
+c    Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que
+c       qu'on ait     - pi    a    pi    en longitude
+c       et qu'on ait   pi/2.  a - pi/2.  en latitude
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c      modifiees pour etre configurees comme ci-dessus .
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      INTEGER lons,lats
+      CHARACTER*25 title
+      REAL xd(lons),yd(lats)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons),yf(lats)
+c
+c    ***  Arguments en entree et  sortie ***
+      REAL champd(lons,lats)
+
+c   ***     Variables  locales  ***
+c
+      REAL pi,pis2,depi
+      LOGICAL radianlon, invlon ,radianlat, invlat, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind
+
+      REAL, ALLOCATABLE :: xtemp(:) 
+      REAL, ALLOCATABLE :: ytemp(:) 
+      REAL, ALLOCATABLE :: champf(:,:)
+     
+c
+c      WRITE(6,*) ' conf_dat2d  pour la variable ', title
+
+      ALLOCATE( xtemp(lons) )
+      ALLOCATE( ytemp(lats) )
+      ALLOCATE( champf(lons,lats) )
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+            radianlon = .FALSE.
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        IF ( invlon )   THEN
+
+           DO j = 1, lats
+            DO i = 1,lons
+             champf(i,j) = champd(i,j)
+            ENDDO
+           ENDDO
+
+           DO i = 1 ,lons
+            xf(i) = xtemp(i)
+           ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+           DO i=1,lons
+            IF( xf(i).GT. pi )  THEN
+            GO TO 88
+            ENDIF
+           ENDDO
+
+88         CONTINUE
+c
+           ip180 = i
+
+           DO i = 1,lons
+            IF (xf(i).GT. pi)  THEN
+             xf(i) = xf(i) - depi
+            ENDIF
+           ENDDO
+
+           DO i= ip180,lons
+            ind = i-ip180 +1
+            xtemp(ind) = xf(i)
+           ENDDO
+
+           DO i= ind +1,lons
+            xtemp(i) = xf(i-ind)
+           ENDDO
+
+c   .....    on tourne les longitudes  pour  champf ....
+c
+           DO j = 1,lats
+
+             DO i = ip180,lons
+              ind  = i-ip180 +1
+              champd (ind,j) = champf (i,j)
+             ENDDO
+   
+             DO i= ind +1,lons
+              champd (i,j)  = champf (i-ind,j)
+             ENDDO
+
+           ENDDO
+
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+
+         IF ( invlat )    THEN
+
+           DO j = 1,lats
+            yf(j) = ytemp(j)
+           ENDDO
+
+           DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j) = champd(i,j)
+             ENDDO
+           ENDDO
+
+           DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1) = champf (i,j)
+              ENDDO
+           ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+
+c        
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+
+      ENDIF
+c
+        DEALLOCATE(champf)
+
+       DO i = 1, lons
+        xf(i) = xtemp(i)
+       ENDDO
+       DO j = 1, lats
+        yf(j) = ytemp(j)
+       ENDDO
+
+      deallocate(xtemp)
+      deallocate(ytemp)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_dat3d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_dat3d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_dat3d.F	(revision 984)
@@ -0,0 +1,296 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf,
+     ,                                 champd , interbar             )
+c
+c     Auteur : P. Le Van
+c
+c    Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon 
+c       qu'on ait     - pi    a    pi    en longitude
+c       qu'on ait      pi/2.  a - pi/2.  en latitude
+c      et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos.
+c           (     en Pascals   ) .
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      zd  les pressions initiales
+c
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c       modifiees pour etre configurees comme ci-dessus .
+c      zf  les pressions en sortie
+c
+c      champd   en meme temps le champ initial et  final
+c
+c      interbar = .TRUE.  si on appelle l'interpo. barycentrique inter_barxy
+c          sinon , l'interpolation   grille_m  ( grid_atob ) .
+c
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      CHARACTER*(*) :: title
+      INTEGER lons, lats, levs
+      REAL xd(lons), yd(lats), zd(levs)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons), yf(lats), zf(levs)
+
+c    ***  Arguments en entree et  sortie ***
+      REAL  champd(lons,lats,levs)
+
+c    ***  Variables locales  ***
+c
+      REAL pi,pis2,depi,presmax
+      LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind,l
+
+      REAL, ALLOCATABLE :: xtemp(:)
+      REAL, ALLOCATABLE :: ytemp(:)
+      REAL, ALLOCATABLE :: ztemp(:)
+      REAL, ALLOCATABLE :: champf(:,:,:)
+     
+
+c      WRITE(6,*) '  Conf_dat3d  pour  ',title
+
+      ALLOCATE(xtemp(lons))
+      ALLOCATE(ytemp(lats))
+      ALLOCATE(ztemp(levs))
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+      DO l = 1, levs
+       ztemp(l) = zd(l)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        alloc =.FALSE.
+
+        IF ( invlon )   THEN
+
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+
+            DO i = 1 ,lons
+             xf(i) = xtemp(i)
+            ENDDO
+
+            DO l = 1, levs
+             DO j = 1, lats
+              DO i= 1, lons
+               champf (i,j,l)  = champd (i,j,l)
+              ENDDO
+             ENDDO
+            ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+            DO i=1,lons
+             IF( xf(i).GT. pi )  THEN
+              GO TO 88
+             ENDIF
+            ENDDO
+
+88          CONTINUE
+c
+            ip180 = i
+
+            DO i = 1,lons
+             IF (xf(i).GT. pi)  THEN
+              xf(i) = xf(i) - depi
+             ENDIF
+            ENDDO
+
+            DO i= ip180,lons
+             ind = i-ip180 +1
+             xtemp(ind) = xf(i)
+            ENDDO
+
+            DO i= ind +1,lons
+             xtemp(i) = xf(i-ind)
+            ENDDO
+
+c   .....    on tourne les longitudes  pour champf  ....
+c
+            DO l = 1,levs
+              DO j = 1,lats
+               DO i = ip180,lons
+                ind  = i-ip180 +1
+                champd (ind,j,l) = champf (i,j,l)
+               ENDDO
+   
+               DO i= ind +1,lons
+                champd (i,j,l)  = champf (i-ind,j,l)
+               ENDDO
+              ENDDO
+            ENDDO
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+         
+         IF ( invlat )    THEN
+
+           IF(.NOT.alloc)  THEN 
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+           ENDIF
+
+           DO j = 1, lats
+            yf(j) = ytemp(j)
+           ENDDO
+         
+           DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+
+            DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1,l) = champf (i,j,l)
+              ENDDO
+            ENDDO
+          ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+c
+c
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+      ENDIF
+c
+
+      invlev = .FALSE.
+      IF( ztemp(1).LT.ztemp(levs) )  invlev = .TRUE.
+
+      presmax = MAX( ztemp(1), ztemp(levs) )
+      IF( presmax.LT.1200. ) THEN
+         DO l = 1,levs
+           ztemp(l) = ztemp(l) * 100.
+         ENDDO
+      ENDIF
+
+      IF( invlev )  THEN
+
+          IF(.NOT.alloc)  THEN
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+          ENDIF
+
+          DO l = 1,levs
+            zf(l) = ztemp(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+          DO l = 1,levs
+            ztemp(levs+1-l) = zf(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champd(i,j,levs+1-l) = champf(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+
+      ENDIF
+
+         IF(alloc)  DEALLOCATE(champf)
+
+         DO i = 1, lons
+           xf(i) = xtemp(i)
+         ENDDO
+         DO j = 1, lats
+           yf(j) = ytemp(j)
+         ENDDO
+         DO l = 1, levs
+           zf(l) = ztemp(l)
+         ENDDO
+
+      DEALLOCATE(xtemp)
+      DEALLOCATE(ytemp)
+      DEALLOCATE(ztemp)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_gcm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_gcm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_gcm.F	(revision 984)
@@ -0,0 +1,824 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
+c
+      use IOIPSL
+      use misc_mod
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "clesphys.h"
+#include "iniprint.h"
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy, tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+      adjust=.false.
+      call getin('adjust',adjust)
+      
+      itaumax=0
+      call getin('itaumax',itaumax);
+      if (itaumax<=0) itaumax=HUGE(itaumax)
+      
+!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)
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = raz_date
+!Config  Desc = Remise a zero de la date initiale
+!Config  Def  = 0 (pas de remise a zero)
+!Config  Help = Remise a zero de la date initiale 
+!Config         0 pas de remise a zero, on garde la date du fichier restart
+!Config         1 prise en compte de la date de gcm.def avec remise a zero
+!Config         des compteurs de pas de temps
+      raz_date = 0
+      CALL getin('raz_date', raz_date)
+
+!Config  Key  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps)
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+!Config  Key  = iapp_tracvl
+!Config  Desc = frequence du groupement des flux 
+!Config  Def  = iperiod
+!Config  Help = frequence du groupement des flux (en pas de temps) 
+       iapp_tracvl = iperiod
+       CALL getin('iapp_tracvl',iapp_tracvl)
+
+!Config  Key  = iconser
+!Config  Desc = periode de sortie des variables de controle
+!Config  Def  = 240  
+!Config  Help = periode de sortie des variables de controle
+!Config         (En pas de temps)
+       iconser = 240  
+       CALL getin('iconser', iconser)
+
+!Config  Key  = iecri
+!Config  Desc = periode d'ecriture du fichier histoire
+!Config  Def  = 1
+!Config  Help = periode d'ecriture du fichier histoire (en jour) 
+       iecri = 1
+       CALL getin('iecri',iecri)
+
+
+!Config  Key  = periodav
+!Config  Desc = periode de stockage fichier histmoy
+!Config  Def  = 1
+!Config  Help = periode de stockage fichier histmoy (en jour) 
+       periodav = 1.
+       CALL getin('periodav',periodav)
+
+!Config  Key  = idissip
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 10
+!Config  Help = periode de la dissipation 
+!Config         (en pas) ... a completer !
+       idissip = 10
+       CALL getin('idissip',idissip)
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+!Config  Key  = coefdis
+!Config  Desc = coefficient pour gamdissip
+!Config  Def  = 0
+!Config  Help = coefficient pour gamdissip  
+       coefdis = 0.
+       CALL getin('coefdis',coefdis)
+
+!Config  Key  = purmats
+!Config  Desc = Schema d'integration
+!Config  Def  = n
+!Config  Help = Choix du schema d'integration temporel.
+!Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+       purmats = .FALSE.
+       CALL getin('purmats',purmats)
+
+!Config  Key  = ok_guide
+!Config  Desc = Guidage
+!Config  Def  = n
+!Config  Help = Guidage
+       ok_guide = .FALSE.
+       CALL getin('ok_guide',ok_guide)
+
+c    ...............................................................
+
+!Config  Key  = iflag_phys
+!Config  Desc = Avec ls physique 
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       iflag_phys = 1
+       CALL getin('iflag_phys',iflag_phys)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+
+!Config  Key  = ecritphy
+!Config  Desc = Frequence d'ecriture de la physique
+!Config  Def  = 1
+!Config  Help = frequence  de l'ecriture du fichier histphy
+!Config         en jours.
+       ecritphy = 1
+       CALL getin('ecritphy',ecritphy)
+
+!Config  Key  = cycle_diurne
+!Config  Desc = Cycle ddiurne
+!Config  Def  = y
+!Config  Help = Cette option permet d'eteidre le cycle diurne.
+!Config         Peut etre util pour accelerer le code !
+       cycle_diurne = .TRUE.
+       CALL getin('cycle_diurne',cycle_diurne)
+
+!Config  Key  = soil_model
+!Config  Desc = Modele de sol
+!Config  Def  = y
+!Config  Help = Choix du modele de sol (Thermique ?)
+!Config         Option qui pourait un string afin de pouvoir
+!Config         plus de choix ! Ou meme une liste d'options !
+       soil_model = .TRUE.
+       CALL getin('soil_model',soil_model)
+
+!Config  Key  = new_oliq
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = y
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       new_oliq = .TRUE.
+       CALL getin('new_oliq',new_oliq)
+
+!Config  Key  = ok_orodr
+!Config  Desc = Orodr ???
+!Config  Def  = y
+!Config  Help = Y en a pas comprendre !
+!Config         
+       ok_orodr = .TRUE.
+       CALL getin('ok_orodr',ok_orodr)
+
+!Config  Key  =  ok_orolf
+!Config  Desc = Orolf ??
+!Config  Def  = y
+!Config  Help = Connais pas !
+       ok_orolf = .TRUE.
+       CALL getin('ok_orolf', ok_orolf)
+
+!Config  Key  = ok_limitvrai
+!Config  Desc = Force la lecture de la bonne annee
+!Config  Def  = n
+!Config  Help = On peut forcer le modele a lire le
+!Config         fichier SST de la bonne annee. C'est une tres bonne
+!Config         idee, pourquoi ne pas mettre toujours a y ???
+       ok_limitvrai = .FALSE.
+       CALL getin('ok_limitvrai',ok_limitvrai)
+
+!Config  Key  = nbapp_rad
+!Config  Desc = Frequence d'appel au rayonnement
+!Config  Def  = 12
+!Config  Help = Nombre  d'appels des routines de rayonnements
+!Config         par jour.
+       nbapp_rad = 12
+       CALL getin('nbapp_rad',nbapp_rad)
+
+!Config  Key  = iflag_con
+!Config  Desc = Flag de convection
+!Config  Def  = 2
+!Config  Help = Flag  pour la convection les options suivantes existent :
+!Config         1 pour LMD,
+!Config         2 pour Tiedtke,
+!Config         3 pour CCM(NCAR)  
+       iflag_con = 2
+       CALL getin('iflag_con',iflag_con)
+!
+!Config  Key  = ip_ebil_dyn
+!Config  Desc = PRINT level for energy conserv. diag.
+!Config  Def  = 0
+!Config  Help = PRINT level for energy conservation diag. ;
+!               les options suivantes existent :
+!Config         0 pas de print
+!Config         1 pas de print
+!Config         2 print,
+       ip_ebil_dyn = 0
+       CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+!
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = FLOAT( iflag_con )
+                          clesphy0(2) = FLOAT( nbapp_rad )
+
+       IF( cycle_diurne  ) clesphy0(3) =  1.
+       IF(   soil_model  ) clesphy0(4) =  1.
+       IF(     new_oliq  ) clesphy0(5) =  1.
+       IF(     ok_orodr  ) clesphy0(6) =  1.
+       IF(     ok_orolf  ) clesphy0(7) =  1.
+       IF(  ok_limitvrai ) clesphy0(8) =  1.
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clonn = 0.
+       CALL getin('clon',clonn)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clatt = 0.
+       CALL getin('clat',clatt)
+
+c
+c
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        PRINT *,' La valeur de clat passee par run.def est differente de 
+     *  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismxx = 1.0
+       CALL getin('grossismx',grossismxx)
+
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de grossismx passee par run.def est differente  
+     *  de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismyy = 1.0
+       CALL getin('grossismy',grossismyy)
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        PRINT *,' La valeur de grossismy passee par run.def est differen
+     * te de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      PRINT *,' alphax alphay defrun ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' *** fxyhypb lu sur le fichier start est F ',
+     *       'alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' ***  fxyhypb lu sur le fichier start est T ',
+     *        'alors  qu il est  F  sur  run.def  ****  '
+              STOP
+           ENDIF
+      ENDIF
+c
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de dzoomx passee par run.def est differente 
+     *  de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomyy = 0.0
+       CALL getin('dzoomy',dzoomyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        PRINT *,' La valeur de dzoomy passee par run.def est differente 
+     * de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+      
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       tauxx = 3.0
+       CALL getin('taux',tauxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de taux passee par run.def est differente
+     * de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = tauyy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauyy = 3.0
+       CALL getin('tauy',tauyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        PRINT *,' La valeur de tauy passee par run.def est differente
+     * de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+cc
+      IF( .NOT.fxyhypb  )  THEN
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinuss = .TRUE.
+       CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' *** ysinus lu sur le fichier start est F ',
+     *       'alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' ***  ysinus lu sur le fichier start est T ',
+     *        'alors  qu il est  F  sur  run.def  ****  '
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' idissip = ', idissip
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' ecritphy = ', ecritphy
+      write(lunout,*)' cycle_diurne = ', cycle_diurne
+      write(lunout,*)' soil_model = ', soil_model
+      write(lunout,*)' new_oliq = ', new_oliq
+      write(lunout,*)' ok_orodr = ', ok_orodr
+      write(lunout,*)' ok_orolf = ', ok_orolf
+      write(lunout,*)' ok_limitvrai = ', ok_limitvrai
+      write(lunout,*)' nbapp_rad = ', nbapp_rad
+      write(lunout,*)' iflag_con = ', iflag_con
+      write(lunout,*)' clonn = ', clonn 
+      write(lunout,*)' clatt = ', clatt
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypbb = ', fxyhypbb
+      write(lunout,*)' dzoomxx = ', dzoomxx
+      write(lunout,*)' dzoomy = ', dzoomyy
+      write(lunout,*)' tauxx = ', tauxx
+      write(lunout,*)' tauyy = ', tauyy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' config_inca = ', config_inca
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      PRINT *,' alphax alphay defrun ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' idissip = ', idissip
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' ecritphy = ', ecritphy
+      write(lunout,*)' cycle_diurne = ', cycle_diurne
+      write(lunout,*)' soil_model = ', soil_model
+      write(lunout,*)' new_oliq = ', new_oliq
+      write(lunout,*)' ok_orodr = ', ok_orodr
+      write(lunout,*)' ok_orolf = ', ok_orolf
+      write(lunout,*)' ok_limitvrai = ', ok_limitvrai
+      write(lunout,*)' nbapp_rad = ', nbapp_rad
+      write(lunout,*)' iflag_con = ', iflag_con
+      write(lunout,*)' clonn = ', clonn 
+      write(lunout,*)' clatt = ', clatt
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypbb = ', fxyhypbb
+      write(lunout,*)' dzoomx = ', dzoomx
+      write(lunout,*)' dzoomy = ', dzoomy
+      write(lunout,*)' taux = ', taux
+      write(lunout,*)' tauy = ', tauy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' config_inca = ', config_inca
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_guide.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_guide.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/conf_guide.F	(revision 984)
@@ -0,0 +1,51 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE conf_guide
+c
+      use IOIPSL
+      use getparam
+      IMPLICIT NONE
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+#include "guide.h"
+
+      call getpar('guide.eff')
+
+      call getpar('online',1,online,'Index de controle du guide')
+      CALL getpar('ncep',.false.,ncep,'Coordonnee vert NCEP ou ECMWF')
+      CALL getpar('ini_anal',.false.,ini_anal,'Initial = analyse')
+
+      CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+      CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+      CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+      CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+      CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+
+c   Constantes de rappel. Unite : fraction de jour
+      CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+      CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+      CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+      CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+      CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+      CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+      CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+      CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+      CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+      CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+
+c   Latitude min et max pour le rappel.
+c   dans le cas ou on 'a les analyses que sur une bande de latitudes.
+      CALL getpar('lat_min_guide',-90.,lat_min_guide
+     s     ,'Latitude minimum pour le guidage ')
+      CALL getpar('lat_max_guide', 90.,lat_max_guide
+     s     ,'Latitude maximum pour le guidage ')
+
+
+      CALL getpar
+
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/control.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/control.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/control.h	(revision 984)
@@ -0,0 +1,24 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'control.h'
+
+      COMMON/control/nday,day_step,                                     &
+     &              iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , &
+     &              periodav,ecritphy,iecrimoy,dayref,anneeref,         &
+     &              raz_date,offline,ip_ebil_dyn,config_inca
+
+      INTEGER   nday,day_step,iperiod,iapp_tracvl,iconser,iecri,        &
+     &          idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date      &
+     &          ,ip_ebil_dyn
+      REAL periodav, ecritphy
+      logical offline
+      CHARACTER*4 config_inca
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/convflu_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/convflu_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/convflu_p.F	(revision 984)
@@ -0,0 +1,84 @@
+      SUBROUTINE convflu_p( xflu,yflu,nbniv,convfl )
+c
+c  P. Le Van
+c
+c
+c    *******************************************************************
+c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+c      composantes xflu et yflu ,variables extensives .  ......
+c    *******************************************************************
+c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+c      convfl                est  un argument de sortie pour le s-pg .
+c
+c     njxflu  est le nombre de lignes de latitude de xflu, 
+c     ( = jjm ou jjp1 )
+c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      REAL       xflu,yflu,convfl,convpn,convps
+      INTEGER    l,ij,nbniv
+      DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) ,
+     *         convfl( ip1jmp1,nbniv )
+c
+      INTEGER ijb,ije
+      EXTERNAL   SSUM
+      REAL       SSUM
+c
+c
+#include "comgeom.h"
+c
+     
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+      DO 5 l = 1,nbniv
+c
+        ijb=ij_begin
+        ije=ij_end+iip1
+      
+        IF (pole_nord) ijb=ij_begin+iip1
+        IF (pole_sud)  ije=ij_end-iip1
+        
+        DO 2  ij = ijb , ije - 1
+          convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l)   +
+     *                     yflu(ij +1,l ) - yflu( ij -iim,l )
+   2    CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+        DO 3 ij = ijb,ije,iip1
+          convfl( ij,l ) = convfl( ij + iim,l )
+   3    CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+        IF (pole_nord) THEN
+      
+          convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+        
+          DO ij = 1,iip1
+            convfl(ij,l) = convpn * aire(ij) / apoln
+          ENDDO
+        
+        ENDIF
+      
+        IF (pole_sud) THEN
+        
+          convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+        
+          DO ij = 1,iip1
+            convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols
+          ENDDO
+        
+        ENDIF
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT   
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas1_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas1_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas1_p.F	(revision 984)
@@ -0,0 +1,62 @@
+      SUBROUTINE convmas1_p (pbaru, pbarv, convm )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL, target :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_p( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas2_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas2_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas2_p.F	(revision 984)
@@ -0,0 +1,56 @@
+      SUBROUTINE convmas2_p ( convm )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+      INTEGER ijb,ije,jjb,jje
+ 
+c$OMP MASTER
+c    integration de la convergence de masse de haut  en bas ......
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+c$OMP END MASTER
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/convmas_p.F	(revision 984)
@@ -0,0 +1,71 @@
+      SUBROUTINE convmas_p (pbaru, pbarv, convm )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL, target :: convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+      INTEGER ijb,ije,jjb,jje
+ 
+      
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu_p( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+       
+       jjb=jj_begin
+       jje=jj_end+1
+       if (pole_sud) jje=jj_end
+ 
+       CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+       ijb=ij_begin
+       ije=ij_end+iip1
+       if (pole_sud) ije=ij_end
+            
+      DO      l      = llmm1, 1, -1
+        DO    ij     = ijb, ije
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/coordij.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/coordij.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/coordij.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE coordij(lon,lat,ilon,jlat)
+
+c=======================================================================
+c
+c   calcul des coordonnees i et j de la maille scalaire dans
+c   laquelle se trouve le point (lon,lat) en radian
+c
+c=======================================================================
+
+      IMPLICIT NONE
+      REAL lon,lat
+      INTEGER ilon,jlat
+      INTEGER i,j
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+
+      real zlon,zlat
+
+      zlon=lon*pi/180.
+      zlat=lat*pi/180.
+
+      DO i=1,iim+1
+         IF (rlonu(i).GT.zlon) THEN
+            ilon=i
+            GOTO 10
+         ENDIF
+      ENDDO
+10    CONTINUE
+
+      j=0
+      DO j=1,jjm
+         IF(rlatv(j).LT.zlat) THEN
+            jlat=j
+            GOTO 20
+         ENDIF
+      ENDDO
+20    CONTINUE
+      IF(j.EQ.0) j=jjm+1
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/covcont.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/covcont.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/covcont.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. contravariantes a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO 10 l = 1,klevel
+
+      DO 2  ij = iip2, ip1jm
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = 1,ip1jm
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/covcont_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/covcont_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/covcont_p.F	(revision 984)
@@ -0,0 +1,59 @@
+      SUBROUTINE covcont_p (klevel,ucov, vcov, ucont, vcont )
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. contravariantes a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER ijb_u,ijb_v,ije_u,ije_v
+
+      
+      ijb_u=ij_begin-iip1
+      ijb_v=ij_begin-iip1
+      ije_u=ij_end+iip1
+      ije_v=ij_end+iip1
+      
+      if (pole_nord) then 
+        ijb_u=ij_begin+iip1
+        ijb_v=ij_begin
+      endif
+      
+      if (pole_sud) then
+        ije_u=ij_end-iip1
+        ije_v=ij_end-iip1
+      endif
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO 10 l = 1,klevel
+
+      DO 2  ij = ijb_u,ije_u
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = ijb_v,ije_v
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/covnat_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/covnat_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/covnat_p.F	(revision 984)
@@ -0,0 +1,75 @@
+!
+! $Header$
+!
+      SUBROUTINE covnat_p(klevel,ucov, vcov, unat, vnat )
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  F Hourdin Phu LeVan
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. naturelles a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER :: ijb,ije
+      
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (pole_nord) then
+        DO l = 1,klevel
+           DO ij = 1, iip1
+              unat (ij,l) =0.
+           END DO
+        ENDDO
+      endif
+
+      if (pole_sud) then
+        DO l = 1,klevel
+           DO ij = ip1jm+1, ip1jmp1  
+            unat (ij,l) =0.
+           END DO
+        ENDDO
+      endif
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO l = 1,klevel
+         DO ij = ijb, ije
+            unat( ij,l ) = ucov( ij,l ) / cu(ij)
+         ENDDO
+      END DO
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+     
+      DO l = 1,klevel
+         DO ij = 1,ip1jm
+            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+         ENDDO
+
+      ENDDO
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/cray.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/cray.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/cray.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/defrun.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/defrun.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/defrun.F	(revision 984)
@@ -0,0 +1,502 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE defrun( tapedef, etatinit, clesphy0 )
+c
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c
+c     Arguments :
+c
+c     tapedef   :
+c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+c     -metres  du zoom  avec  celles lues sur le fichier start .
+c      clesphy0 :  sortie  .
+c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+c
+c   Declarations :
+c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "clesph0.h"
+c
+c
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      INTEGER   tapeout
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy,tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      
+c
+c  -------------------------------------------------------------------
+c
+c       .........     Version  du 29/04/97       ..........
+c
+c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+c      tetatemp   ajoutes  pour la dissipation   .
+c
+c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+c
+c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+c
+c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+c                de limit.dat ( dic)                        ...........
+c           Sinon  etatinit = . FALSE .
+c
+c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+c    lectba .  
+c   Ces parmetres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      tapeout = 6
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+      OPEN( tapedef,file ='gcm.def',status='old',form='formatted')
+
+
+      READ (tapedef,9000) ch1,ch2,ch3
+      WRITE(tapeout,9000) ch1,ch2,ch3
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dayref
+      WRITE(tapeout,9001) ch1,'dayref'
+      WRITE(tapeout,*)    dayref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    anneeref
+      WRITE(tapeout,9001) ch1,'anneeref'
+      WRITE(tapeout,*)    anneeref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nday
+      WRITE(tapeout,9001) ch1,'nday'
+      WRITE(tapeout,*)    nday
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    day_step
+      WRITE(tapeout,9001) ch1,'day_step'
+      WRITE(tapeout,*)    day_step
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iperiod
+      WRITE(tapeout,9001) ch1,'iperiod'
+      WRITE(tapeout,*)    iperiod
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iapp_tracvl
+      WRITE(tapeout,9001) ch1,'iapp_tracvl'
+      WRITE(tapeout,*)    iapp_tracvl
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iconser
+      WRITE(tapeout,9001) ch1,'iconser'
+      WRITE(tapeout,*)    iconser
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iecri
+      WRITE(tapeout,9001) ch1,'iecri'
+      WRITE(tapeout,*)    iecri
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    periodav
+      WRITE(tapeout,9001) ch1,'periodav'
+      WRITE(tapeout,*)    periodav
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    idissip
+      WRITE(tapeout,9001) ch1,'idissip'
+      WRITE(tapeout,*)    idissip
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    lstardis
+      WRITE(tapeout,9001) ch1,'lstardis'
+      WRITE(tapeout,*)    lstardis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergdiv
+      WRITE(tapeout,9001) ch1,'nitergdiv'
+      WRITE(tapeout,*)    nitergdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergrot
+      WRITE(tapeout,9001) ch1,'nitergrot'
+      WRITE(tapeout,*)    nitergrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    niterh
+      WRITE(tapeout,9001) ch1,'niterh'
+      WRITE(tapeout,*)    niterh
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagdiv
+      WRITE(tapeout,9001) ch1,'tetagdiv'
+      WRITE(tapeout,*)    tetagdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagrot
+      WRITE(tapeout,9001) ch1,'tetagrot'
+      WRITE(tapeout,*)    tetagrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetatemp
+      WRITE(tapeout,9001) ch1,'tetatemp'
+      WRITE(tapeout,*)    tetatemp
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    coefdis
+      WRITE(tapeout,9001) ch1,'coefdis'
+      WRITE(tapeout,*)    coefdis
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    purmats
+      WRITE(tapeout,9001) ch1,'purmats'
+      WRITE(tapeout,*)    purmats
+
+c    ...............................................................
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_phys
+      WRITE(tapeout,9001) ch1,'iflag_phys'
+      WRITE(tapeout,*)    iflag_phys
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iphysiq
+      WRITE(tapeout,9001) ch1,'iphysiq'
+      WRITE(tapeout,*)    iphysiq
+
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ecritphy
+      WRITE(tapeout,9001) ch1,'ecritphy'
+      WRITE(tapeout,*)    ecritphy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    cycle_diurne
+      WRITE(tapeout,9001) ch1,'cycle_diurne'
+      WRITE(tapeout,*)    cycle_diurne
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    soil_model
+      WRITE(tapeout,9001) ch1,'soil_model'
+      WRITE(tapeout,*)    soil_model
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    new_oliq
+      WRITE(tapeout,9001) ch1,'new_oliq'
+      WRITE(tapeout,*)    new_oliq
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orodr
+      WRITE(tapeout,9001) ch1,'ok_orodr'
+      WRITE(tapeout,*)    ok_orodr
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orolf
+      WRITE(tapeout,9001) ch1,'ok_orolf'
+      WRITE(tapeout,*)    ok_orolf
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_limitvrai
+      WRITE(tapeout,9001) ch1,'ok_limitvrai'
+      WRITE(tapeout,*)    ok_limitvrai
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nbapp_rad
+      WRITE(tapeout,9001) ch1,'nbapp_rad'
+      WRITE(tapeout,*)    nbapp_rad
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_con
+      WRITE(tapeout,9001) ch1,'iflag_con'
+      WRITE(tapeout,*)    iflag_con
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = FLOAT( iflag_con )
+                          clesphy0(2) = FLOAT( nbapp_rad )
+
+       IF( cycle_diurne  ) clesphy0(3) =  1.
+       IF(   soil_model  ) clesphy0(4) =  1.
+       IF(     new_oliq  ) clesphy0(5) =  1.
+       IF(     ok_orodr  ) clesphy0(6) =  1.
+       IF(     ok_orolf  ) clesphy0(7) =  1.
+       IF(  ok_limitvrai ) clesphy0(8) =  1.
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+      IF( etatinit ) GO TO 100
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clonn
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clonn
+      IF( ABS(clon - clonn).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clatt
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clatt
+
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismxx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismxx
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismyy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismyy
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypbb
+      WRITE(tapeout,9001) ch1,'fxyhypbb'
+      WRITE(tapeout,*)    fxyhypbb
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F'
+     *,      '                   alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t'
+     *,      '                   alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomxx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomyy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomyy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauxx
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    tauxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauyy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauyy
+
+      IF( fxyhypb )  THEN
+
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de taux passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de tauy passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+      ENDIF
+      
+cc
+      IF( .NOT.fxyhypb  )  THEN
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ysinuss
+        WRITE(tapeout,9001) ch1,'ysinus'
+        WRITE(tapeout,*)    ysinuss
+
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est T',
+     *       ' alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+      WRITE(6,*) ' alphax alphay defrun ',alphax,alphay
+
+      CLOSE(tapedef)
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clon
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clon
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clat
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clat
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismy
+
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) '***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypb
+      WRITE(tapeout,9001) ch1,'fxyhypb'
+      WRITE(tapeout,*)    fxyhypb
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    taux
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    taux
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ysinus
+      WRITE(tapeout,9001) ch1,'ysinus'
+      WRITE(tapeout,*)    ysinus
+       
+      WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a12)
+cc
+      CLOSE(tapedef)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/description.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/description.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/description.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      character (len=120) :: descript
+      common /titre/descript
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/diagedyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/diagedyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/diagedyn.F	(revision 984)
@@ -0,0 +1,319 @@
+!
+! $Header$
+!
+
+C======================================================================
+      SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime
+     e  , ucov    , vcov , ps, p ,pk , teta , q, ql)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la dynamique.
+C
+C
+c======================================================================
+C Arguments: 
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+C uconv, vconv-input-R- vents covariants (m/s)
+C ps-------input-R- Surface pressure (Pa)
+C p--------input-R- pressure at the interfaces
+C pk-------input-R- pk= (p/Pref)**kappa
+c teta-----input-R- potential temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c aire-----input-R- mesh surafce (m2)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+#ifdef CPP_PHYS
+#include "../phylmd/YOMCST.h"
+#include "../phylmd/YOETHF.h"
+#endif
+C
+      INTEGER imjmp1
+      PARAMETER( imjmp1=iim*jjp1)
+c     Input variables
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )  ! pression aux interfac.des couches
+      REAL pk (ip1jmp1,llm  )  ! = (p/Pref)**kappa
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm)               ! champs eau vapeur
+      REAL ql(ip1jmp1,llm)               ! champs eau liquide
+
+
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL ecin(ip1jmp1,llm)
+
+      REAL zaire(imjmp1)
+      REAL zps(imjmp1)
+      REAL zairm(imjmp1,llm)
+      REAL zecin(imjmp1,llm)
+      REAL zpaprs(imjmp1,llm)
+      REAL zpk(imjmp1,llm)
+      REAL zt(imjmp1,llm)
+      REAL zh(imjmp1,llm)
+      REAL zqw(imjmp1,llm)
+      REAL zql(imjmp1,llm)
+      REAL zqs(imjmp1,llm)
+
+      REAL  zqw_col(imjmp1)
+      REAL  zql_col(imjmp1)
+      REAL  zqs_col(imjmp1)
+      REAL  zec_col(imjmp1)
+      REAL  zh_dair_col(imjmp1)
+      REAL  zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k, jj, ij , l ,ip1jjm1
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+
+
+#ifdef CPP_PHYS
+c======================================================================
+C     Compute Kinetic enrgy
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL massdair( p, masse )
+c======================================================================
+C
+C
+      print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?'
+      return
+C     On ne garde les donnees que dans les colonnes i=1,iim
+      DO jj = 1,jjp1
+        ip1jjm1=iip1*(jj-1)
+        DO ij =  1,iim
+          i=iim*(jj-1)+ij
+          zaire(i)=aire(ij+ip1jjm1)
+          zps(i)=ps(ij+ip1jjm1)
+        ENDDO 
+      ENDDO 
+C 3D arrays
+      DO l  =  1, llm
+        DO jj = 1,jjp1
+          ip1jjm1=iip1*(jj-1)
+          DO ij =  1,iim
+            i=iim*(jj-1)+ij
+            zairm(i,l) = masse(ij+ip1jjm1,l)
+            zecin(i,l) = ecin(ij+ip1jjm1,l)
+            zpaprs(i,l) = p(ij+ip1jjm1,l)
+            zpk(i,l) = pk(ij+ip1jjm1,l)
+            zh(i,l) = teta(ij+ip1jjm1,l)
+            zqw(i,l) = q(ij+ip1jjm1,l)
+            zql(i,l) = ql(ij+ip1jjm1,l)
+            zqs(i,l) = 0.
+          ENDDO 
+        ENDDO 
+      ENDDO 
+C
+C     Reset variables
+      DO i = 1, imjmp1
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, llm
+        DO i = 1, imjmp1
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +zecin(i,k)*zairm(i,k)
+C         Air enthalpy
+          zt(i,k)= zh(i,k) * zpk(i,k) / RCPD
+          zh_dair_col(i) = zh_dair_col(i)
+     $        + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLVTT*zql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLSTT*zqs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,imjmp1
+        qw_tot = qw_tot + zqw_col(i)
+        ql_tot = ql_tot + zql_col(i)
+        qs_tot = qs_tot + zqs_col(i)
+        ec_tot = ec_tot + zec_col(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)
+        airetot=airetot+zaire(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+C        WRITE(6,9003) tit,pas(idiag), ec_tot
+ 9003   format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6))
+        WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec
+ 9004   format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+#else
+      print*,'Pour l instant diagedyn a besoin de la physique'
+#endif
+      RETURN 
+      END 
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dissip_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dissip_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dissip_p.F	(revision 984)
@@ -0,0 +1,213 @@
+      SUBROUTINE dissip_p( vcov,ucov,teta,p, dv,du,dh )
+c
+      USE parallel
+      USE write_field_p
+      IMPLICIT NONE
+
+
+c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+c                                 (  10/01/98  )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation horizontale
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comdissnew.h"
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL  p( ip1jmp1,llmp1 )
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
+      REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
+      REAL te1dt(llm),te2dt(llm),te3dt(llm)
+      REAL deltapres(ip1jmp1,llm)
+
+      INTEGER l,ij
+
+      REAL  SSUM
+      integer :: ijb,ije
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+         te1dt(l) = tetaudiv(l) * dtdiss
+         te2dt(l) = tetaurot(l) * dtdiss
+         te3dt(l) = tetah(l)    * dtdiss
+      ENDDO
+c$OMP END DO NOWAIT
+c      CALL initial0( ijp1llm, du )
+c      CALL initial0( ijmllm , dv )
+c      CALL initial0( ijp1llm, dh )
+     
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+        du(ijb:ije,l)=0
+        dh(ijb:ije,l)=0
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+        dv(ijb:ije,l)=0
+      ENDDO
+c$OMP END DO NOWAIT
+     
+c-----------------------------------------------------------------------
+c   Calcul de la dissipation:
+c   -------------------------
+
+c   Calcul de la partie   grad  ( div ) :
+c   -------------------------------------
+      
+     
+      
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+         CALL gradiv2_p( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+         CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ENDIF
+
+c      call write_field3d_p('gdx',reshape(gdx,(/iip1,jjp1,llm/)))
+c     call write_field3d_p('gdy',reshape(gdy,(/iip1,jjm,llm/)))
+c       stop
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO l=1,llm
+         if (pole_nord) then
+           DO ij = 1, iip1
+              gdx(     ij ,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_sud) then
+           DO ij = 1, iip1
+              gdx(ij+ip1jm,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_nord) ijb=ij_begin+iip1
+         DO ij = ijb,ije
+            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+         ENDDO
+
+         if (pole_nord) ijb=ij_begin
+         DO ij = ijb,ije
+            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+         ENDDO
+
+       ENDDO
+c$OMP END DO NOWAIT
+c   calcul de la partie   n X grad ( rot ):
+c   ---------------------------------------
+
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+         CALL nxgraro2_p( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+         CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
+      ENDIF
+
+c      call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/)))
+c      call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/)))
+c          stop
+
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+         
+         if (pole_nord) then
+           DO ij = 1, iip1
+              grx(ij,l) = 0.
+           ENDDO
+         endif
+         
+         if (pole_nord) ijb=ij_begin+iip1
+         DO ij = ijb,ije
+            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+         ENDDO
+         
+         if (pole_nord) ijb=ij_begin
+         DO ij =  ijb, ije
+            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+         ENDDO
+      
+      ENDDO
+c$OMP END DO NOWAIT
+
+c   calcul de la partie   div ( grad ):
+c   -----------------------------------
+
+        
+      IF(lstardis) THEN
+c      IF (.FALSE.) THEN
+    
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+       DO l = 1, llm
+          DO ij = ijb, ije
+            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+          ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+         CALL divgrad2_p( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+         CALL divgrad_p ( llm,teta, niterh, gdx        )
+      ENDIF
+
+c      call write_field3d_p('gdx2',reshape(gdx,(/iip1,jmp1,llm/)))
+c      stop
+
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1,llm
+         DO ij = ijb,ije
+            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/disvert.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/disvert.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/disvert.F	(revision 984)
@@ -0,0 +1,170 @@
+!
+! $Header$
+!
+      SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL pa,preff
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+       real zzz(1:llm+1)
+       real dzz(1:llm)
+      real zk,zkm1,dzk1,dzk2,k0,k1
+c
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) h           ! hauteur d'echelle 8.
+      READ(99,*) deltaz      ! epaiseur de la premiere couche 0.04
+      READ(99,*) beta        ! facteur d'acroissement en haut 1.3
+      READ(99,*) k0          ! nombre de couches dans la transition surf
+      READ(99,*) k1          ! nombre de couches dans la transition haute
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+      write(lunout,*)'h,alpha,k0,k1,beta'
+
+c     read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2
+
+      alpha=deltaz/tanh(1./k0)*2.
+      zkm1=0.
+      sig(1)=1.
+      do l=1,llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/h)
+     + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta))
+        zk=-h*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        write(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2
+        zkm1=zk
+      enddo
+
+      sig(llm+1)=0.
+
+c
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      WRITE(LUNOUT,*)'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
+
+c
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c
+c   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+c
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+cc
+ccc    ap(l) = 0.
+ccc    bp(l) = sig(l)
+
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+c
+      ENDDO
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      write(lunout,*)' BP '
+      write(lunout,*)  bp
+      write(lunout,*)' AP '
+      write(lunout,*)  ap
+
+      write(lunout,*)
+     .'Niveaux de pressions approximatifs aux centres des'
+      write(lunout,*)'couches calcules pour une pression de surface =',
+     .                 preff
+      write(lunout,*)
+     .     'et altitudes equivalentes pour une hauteur d echelle de'
+      write(lunout,*)'8km'
+      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 )
+       write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),'    Z ~ ',
+     .        log(preff/presnivs(l))*8.
+     .  ,'   DZ ~ ',8.*log((ap(l)+bp(l)*preff)/
+     .       max(ap(l+1)+bp(l+1)*preff,1.e-10))
+      ENDDO
+
+      write(lunout,*)' PRESNIVS '
+      write(lunout,*)presnivs
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/disvert0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/disvert0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/disvert0.F	(revision 984)
@@ -0,0 +1,175 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "iniprint.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL pa,preff,presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+       real zzz(1:llm+1)
+       real dzz(1:llm)
+      real zk,zkm1,dzk1,dzk2,k0,k1
+c
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+
+      pa        =  50 000.
+      preff     = 101 325.
+
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) h           ! hauteur d'echelle 8.
+      READ(99,*) deltaz      ! epaiseur de la premiere couche 0.04
+      READ(99,*) beta        ! facteur d'acroissement en haut 1.3
+      READ(99,*) k0          ! nombre de couches dans la transition surf
+      READ(99,*) k1          ! nombre de couches dans la transition haute
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+      WRITE(lunout,*)'h,alpha,k0,k1,beta'
+
+c     read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2
+
+      alpha=deltaz/tanh(1./k0)*2.
+      zkm1=0.
+      sig(1)=1.
+      do l=1,llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/h)
+     + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta))
+        zk=-h*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        WRITE(lunout,*)l,sig(l+1),zk,zk-zkm1,dzk1,dzk2
+        zkm1=zk
+      enddo
+
+      sig(llm+1)=0.
+
+c
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      write(lunout,*)'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
+
+c
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c
+c   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+c
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+cc
+ccc    ap(l) = 0.
+ccc    bp(l) = sig(l)
+
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+c
+      ENDDO
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      write(lunout,*)' BP '
+      write(lunout,*)  bp
+      write(lunout,*)' AP '
+      write(lunout,*)  ap
+
+      write(lunout,*)
+     .'Niveaux de pressions approximatifs aux centres des'
+      write(lunout,*)
+     .'couches calcules pour une pression de surface =',preff
+      write(lunout,*)
+     .'et altitudes equivalentes pour une hauteur d echelle de'
+      write(lunout,*)'8km'
+      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 )
+       write(lunout,*)'PRESNIVS(',l,')=',presnivs(l),'    Z ~ ',
+     .        log(preff/presnivs(l))*8.
+     .  ,'   DZ ~ ',8.*log((ap(l)+bp(l)*preff)/
+     .       max(ap(l+1)+bp(l+1)*preff,1.e-10))
+      ENDDO
+
+      write(lunout,*)' PRESNIVS '
+      write(lunout,*)presnivs
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg.F	(revision 984)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE diverg(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_gam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_gam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_gam.F	(revision 984)
@@ -0,0 +1,80 @@
+!
+! $Header$
+!
+      SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam ,
+     *                       unsapolnga,unsapolsga,  x, y,  div )
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+      REAL unsapolnga,unsapolsga
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+      INTEGER   l,ij
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     = (  
+     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
+     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
+     *         unsairegam( ij+1 )
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+        sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn 
+         div( ij + ip1jm, l ) =   sumyps 
+        ENDDO
+  10  CONTINUE
+c
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_gam_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_gam_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_gam_p.F	(revision 984)
@@ -0,0 +1,97 @@
+      SUBROUTINE diverg_gam_p(klevel,cuvscvgam,cvuscugam,unsairegam ,
+     *                       unsapolnga,unsapolsga,  x, y,  div )
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      USE parallel
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+      REAL unsapolnga,unsapolsga
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+      INTEGER   l,ij
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if(pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 10 l = 1,klevel
+c
+        DO  ij = ijb, ije - 1
+         div( ij + 1, l )     = (  
+     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
+     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
+     *         unsairegam( ij+1 )
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = ijb,ije,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+       if (pole_nord) then
+          DO  ij  = 1,iim
+           aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+          ENDDO
+          sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+c  
+          DO  ij = 1,iip1
+           div(     ij    , l ) = - sumypn 
+          ENDDO
+       endif
+        
+        if (pole_sud) then
+          DO  ij  = 1,iim
+           aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+          ENDDO
+          sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+c  
+          DO  ij = 1,iip1
+           div( ij + ip1jm, l ) =   sumyps 
+          ENDDO
+       endif
+  10  CONTINUE
+c$OMP END DO NOWAIT
+c
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/diverg_p.F	(revision 984)
@@ -0,0 +1,106 @@
+      SUBROUTINE diverg_p(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      USE parallel
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+      INTEGER ijb,ije
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if(pole_sud)  ije=ij_end-iip1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 10 l = 1,klevel
+c
+        DO  ij = ijb, ije - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = ijb,ije,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        if (pole_nord) then
+          DO  ij  = 1,iim
+           aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+          ENDDO
+          sumypn = SSUM ( iim,aiy1,1 ) / apoln
+c
+          DO  ij = 1,iip1
+           div(     ij    , l ) = - sumypn
+          ENDDO
+        endif
+         
+       if (pole_sud) then
+          DO  ij  = 1,iim
+           aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+          ENDDO
+          sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+          DO  ij = 1,iip1
+           div( ij + ip1jm, l ) =   sumyps
+          ENDDO
+        endif
+
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+c
+
+ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, klevel
+           DO ij = ijb,ije
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergf.F	(revision 984)
@@ -0,0 +1,85 @@
+!
+! $Header$
+!
+      SUBROUTINE divergf(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergf_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergf_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergf_p.F	(revision 984)
@@ -0,0 +1,115 @@
+      SUBROUTINE divergf_p(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      USE PARALLEL
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if(pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO 10 l = 1,klevel
+c
+        DO  ij = ijb, ije - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = ijb,ije,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        if (pole_nord) then
+        
+          DO  ij  = 1,iim
+           aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+          ENDDO
+          sumypn = SSUM ( iim,aiy1,1 ) / apoln
+
+c
+          DO  ij = 1,iip1
+           div(     ij    , l ) = - sumypn
+          ENDDO
+          
+        endif
+        
+        if (pole_sud) then
+        
+          DO  ij  = 1,iim
+           aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+          ENDDO
+          sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+          DO  ij = 1,iip1
+           div( ij + ip1jm, l ) =   sumyps
+          ENDDO
+          
+        endif
+        
+  10    CONTINUE
+c$OMP END DO NOWAIT
+
+c
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        
+        CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, klevel
+           DO ij = ijb,ije
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divergst.F	(revision 984)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+      SUBROUTINE divergst(klevel,x,y,div)
+      IMPLICIT NONE
+c
+c     P. Le Van
+c
+c  ******************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y...
+c           x et y  etant des composantes contravariantes   ...
+c  ****************************************************************
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   -------------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER ij,l,i
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+
+      REAL SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1 ij = iip2, ip1jm - 1
+      div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
+   1  CONTINUE
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      div( ij,l ) = div( ij + iim,l )
+   3  CONTINUE
+c
+c     ....  calcul  aux poles  .....
+c
+c
+      DO 5 i  = 1,iim
+      aiy1(i)= y(i,l)
+      aiy2(i)= y(i+ip1jmi1,l)
+   5  CONTINUE
+      sumypn = SSUM ( iim,aiy1,1 )
+      sumyps = SSUM ( iim,aiy2,1 )
+      DO 7 i = 1,iip1
+      div(     i    , l ) = - sumypn/iim
+      div( i + ip1jm, l ) =   sumyps/iim
+   7  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad.F	(revision 984)
@@ -0,0 +1,56 @@
+!
+! $Header$
+!
+      SUBROUTINE divgrad (klevel,h, lh, divgra )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c  Auteur :   P. Le Van
+c  ----------
+c
+c                              lh
+c      calcul de  (div( grad ))   de h  .....
+c      h  et lh  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+c
+      DO 10 iter = 1,lh
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1  )
+
+      CALL    grad (klevel,divgra, ghx  , ghy          )
+      CALL  diverg (klevel,  ghx , ghy  , divgra       )
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1)
+
+      DO 5 l = 1,klevel
+      DO 4  ij = 1, ip1jmp1
+      divgra( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad2.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
+c
+c     P. Le Van
+c
+c   ***************************************************************
+c
+c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
+c   ****************************************************************
+c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+c         divgra     est  un argument  de sortie pour le s-prg
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comdissipn.h"
+
+c    .......    variables en arguments   .......
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+      REAL divgra( ip1jmp1,klevel)
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+
+c
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+
+c
+      CALL laplacien( klevel, divgra, divgra )
+     
+      DO l = 1, klevel
+       DO ij = 1, ip1jmp1
+        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+       ENDDO
+      ENDDO
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+   
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+       CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
+     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
+      ENDDO
+c
+c    ...............................................................
+ 
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c
+      CALL laplacien ( klevel, divgra, divgra )
+c
+      DO l  = 1,klevel
+      DO ij = 1,ip1jmp1
+      divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad2_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad2_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad2_p.F	(revision 984)
@@ -0,0 +1,118 @@
+      SUBROUTINE divgrad2_p ( klevel, h, deltapres, lh, divgra_out )
+c
+c     P. Le Van
+c
+c   ***************************************************************
+c
+c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
+c   ****************************************************************
+c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+c         divgra     est  un argument  de sortie pour le s-prg
+c
+      USE parallel
+      USE times
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comdissipn.h"
+
+c    .......    variables en arguments   .......
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+      REAL divgra_out( ip1jmp1,klevel)
+      REAL,SAVE :: divgra( ip1jmp1,llm)
+
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+
+      INTEGER ijb,ije
+c
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+c      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, klevel
+        divgra(ijb:ije,l)=h(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(divgra,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      CALL laplacien_p( klevel, divgra, divgra )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO l = 1, klevel
+       DO ij = ijb, ije
+        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO l = 1, klevel
+        DO ij = ijb, ije
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+   
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+c$OMP BARRIER
+c$OMP MASTER
+       call suspend_timer(timer_dissip)
+       call exchange_Hallo(divgra,ip1jmp1,llm,1,1)
+       call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+       CALL laplacien_gam_p ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
+     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
+      ENDDO
+c
+c    ...............................................................
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO l = 1, klevel
+        DO ij = ijb, ije
+          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(divgra,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+      CALL laplacien_p ( klevel, divgra, divgra )
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l  = 1,klevel
+      DO ij = ijb,ije
+      divgra_out(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+      ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/divgrad_p.F	(revision 984)
@@ -0,0 +1,91 @@
+      SUBROUTINE divgrad_p (klevel,h, lh, divgra_out )
+      USE parallel
+      USE times
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c  Auteur :   P. Le Van
+c  ----------
+c
+c                              lh
+c      calcul de  (div( grad ))   de h  .....
+c      h  et lh  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra_out( ip1jmp1,klevel )
+      REAL,SAVE :: divgra( ip1jmp1,llm )
+
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+      
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, klevel      
+      divgra(ijb:ije,l)=h(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+c
+
+c
+      DO 10 iter = 1,lh
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1  )
+
+c      call exchange_Hallo(divgra,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(divgra,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER       
+      CALL    grad_p (klevel,divgra, ghx  , ghy          )
+
+c$OMP BARRIER
+c$OMP MASTER   
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(ghy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER            
+
+      CALL  diverg_p (klevel,  ghx , ghy  , divgra       )
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1)
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,klevel
+      DO 4  ij = ijb, ije
+      divgra_out( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dteta1_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dteta1_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dteta1_p.F	(revision 984)
@@ -0,0 +1,88 @@
+      SUBROUTINE dteta1_p ( teta, pbaru, pbarv, dteta)
+      USE parallel
+      USE write_field_p
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+c
+c   ********************************************************************
+c   ... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dteta 	          sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dteta( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
+
+c
+      INTEGER ijb,ije,jjb,jje
+
+      
+      jjb=jj_begin
+      jje=jj_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO 5 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 1  ij = ijb, ije - 1
+        hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) )
+   1  CONTINUE
+
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+CDIR$ IVDEP
+      DO 2 ij = ijb+iip1-1, ije, iip1
+        hbxu( ij, l ) = hbxu( ij - iim, l )
+   2  CONTINUE
+
+      ijb=ij_begin-iip1
+      if (pole_nord) ijb=ij_begin
+      
+      DO 3 ij = ijb,ije
+        hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) )
+   3  CONTINUE
+
+       if (.not. pole_sud) then
+	  hbxu(ije+1:ije+iip1,l) = 0
+	  hbyv(ije+1:ije+iip1,l) = 0
+	endif
+	
+   5  CONTINUE
+c$OMP END DO NOWAIT
+       
+	
+        CALL  convflu_p ( hbxu, hbyv, llm, dteta )
+
+
+c    stockage dans  dh de la convergence horizont. filtree' du  flux
+c                  ....                           ...........
+c           d'enthalpie potentielle .
+      
+      
+      CALL filtreg_p( dteta,jjb,jje,jjp1, llm, 2, 2, .true., 1)
+      
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dudv1_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dudv1_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dudv1_p.F	(revision 984)
@@ -0,0 +1,64 @@
+      SUBROUTINE dudv1_p ( vorpot, pbaru, pbarv, du, dv )
+      USE parallel
+      IMPLICIT NONE
+c
+c-----------------------------------------------------------------------
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c   calcul du terme de  rotation
+c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
+c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
+c   du  et dv              sont des arguments de sortie pour le s-pg ..
+c
+c-----------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) ,
+     *     pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm )
+      INTEGER  l,ij,ijb,ije
+c
+c
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO 10 l = 1,llm
+c
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 2  ij = ijb, ije-1 
+      du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) *
+     *                    (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) +
+     *                        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
+   2  CONTINUE
+   
+ 
+c
+      if (pole_nord) ijb=ij_begin
+      
+      DO 3 ij = ijb, ije-1 
+      dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) *
+     *                        (   pbaru(ij, l)  +  pbaru(ij+1   , l) +
+     *                       pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
+   3  CONTINUE
+c
+c    .... correction  pour  dv( 1,j,l )  .....
+c    ....   dv(1,j,l)= dv(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 4 ij = ijb, ije, iip1
+      dv( ij,l ) = dv( ij + iim, l )
+   4  CONTINUE
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dudv2_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dudv2_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dudv2_p.F	(revision 984)
@@ -0,0 +1,69 @@
+      SUBROUTINE dudv2_p ( teta, pkf, bern, du, dv  )
+      USE parallel
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *****************************************************************
+c   ..... calcul du terme de pression (gradient de p/densite )   et
+c          du terme de ( -gradient de la fonction de Bernouilli ) ...
+c   *****************************************************************
+c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+c
+c
+c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+c    du et dv          sont des arguments de sortie pour le s-pg  ....
+c
+c=======================================================================
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ),
+     *         du( ip1jmp1,llm ),  dv( ip1jm,llm )
+      INTEGER  l,ij,ijb,ije
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+      DO 2  ij  = ijb, ije - 1
+       du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) *
+     * ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
+   2  CONTINUE
+c
+c
+c    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
+c    ...          du(iip1,j,l) = du(1,j,l)                 ...
+c
+CDIR$ IVDEP
+      DO 3 ij = ijb+iip1-1, ije, iip1
+      du( ij,l ) = du( ij - iim,l )
+   3  CONTINUE
+c
+c
+      if (pole_nord) ijb=ijb-iip1
+
+      DO 4 ij  = ijb,ije
+      dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) *
+     *                             ( pkf(ij+iip1,l) - pkf(  ij,l  ) )
+     *                           +   bern( ij+iip1,l ) - bern( ij  ,l )
+   4  CONTINUE
+c
+   5  CONTINUE
+c$OMP END DO NOWAIT 
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dump2d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dump2d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dump2d.F	(revision 984)
@@ -0,0 +1,46 @@
+!
+! $Header$
+!
+      SUBROUTINE dump2d(im,jm,z,nom_z)
+      IMPLICIT NONE
+      INTEGER im,jm
+      REAL z(im,jm)
+      CHARACTER*80 nom_z
+
+      INTEGER i,j,imin,illm,jmin,jllm
+      REAL zmin,zllm
+
+      PRINT*,nom_z
+
+      zmin=z(1,1)
+      zllm=z(1,1)
+      imin=1
+      illm=1
+      jmin=1
+      jllm=1
+
+      DO j=1,jm
+         DO i=1,im
+            IF(z(i,j).GT.zllm) THEN
+               illm=i
+               jllm=j
+               zllm=z(i,j)
+            ENDIF
+            IF(z(i,j).LT.zmin) THEN
+               imin=i
+               jmin=j
+               zmin=z(i,j)
+            ENDIF
+         ENDDO
+      ENDDO
+
+      PRINT*,'MIN: ',zmin
+      PRINT*,'MAX: ',zllm
+
+      IF(zllm.GT.zmin) THEN
+      DO j=1,jm
+      WRITE(*,'(72i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
+      ENDDO
+      ENDIF
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dynetat0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dynetat0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dynetat0.F	(revision 984)
@@ -0,0 +1,383 @@
+!
+! $Header$
+!
+      SUBROUTINE dynetat0(fichnom,nq,vcov,ucov,
+     .                    teta,q,masse,ps,phis,time)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / L.Fairhead
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Lecture de l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "logic.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+
+      CHARACTER*(*) fichnom
+      INTEGER nq
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+
+      REAL time
+
+c   Variables 
+c
+      INTEGER length,iq
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid
+
+c-----------------------------------------------------------------------
+
+c  Ouverture NetCDF du fichier etat initial
+
+      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier start.nc'
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+
+      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)
+c
+      clon       = tab_cntrl(20)
+      clat       = tab_cntrl(21)
+      grossismx  = tab_cntrl(22)
+      grossismy  = tab_cntrl(23)
+c
+      IF ( tab_cntrl(24).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+c        dzoomx   = tab_cntrl(25)
+c        dzoomy   = tab_cntrl(26)
+c        taux     = tab_cntrl(28)
+c        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)
+c   .................................................................
+c
+c
+      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+      IF(   im.ne.iim           )  THEN
+          PRINT 1,im,iim
+          STOP
+      ELSE  IF( jm.ne.jjm       )  THEN
+          PRINT 2,jm,jjm
+          STOP
+      ELSE  IF( lllm.ne.llm     )  THEN
+          PRINT 3,lllm,llm
+          STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour rlatv"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "aire", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <aire> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <aire>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phis)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <temps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, time)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee <temps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ucov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ucov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ucov>"
+         CALL abort
+      ENDIF
+ 
+      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <vcov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, vcov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <vcov>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <teta> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, teta)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <teta>"
+         CALL abort
+      ENDIF
+
+
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+        ierr =  NF_INQ_VARID (nid, tname(iq), nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent"
+           PRINT*, "          Il est donc initialise a zero"
+           q(:,:,iq)=0.
+        ELSE
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq))
+#endif
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "dynetat0: Lecture echouee pour "//tname(iq)
+             CALL abort
+          ENDIF
+        ENDIF
+      ENDDO
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <masse> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, masse)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <masse>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ps)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_CLOSE(nid)
+
+       day_ini=day_ini+INT(time)
+       time=time-INT(time)
+
+  1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur  dtinteg =',i4//)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/dynredem_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/dynredem_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/dynredem_p.F	(revision 984)
@@ -0,0 +1,686 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE dynredem0_p(fichnom,iday_end,phis,nq)
+      USE IOIPSL
+      USE parallel
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#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 "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(ip1jmp1)
+      CHARACTER*(*) fichnom
+      INTEGER nq
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+
+c-----------------------------------------------------------------------
+      if (mpi_rank==0) then
+      
+      modname='dynredem'
+
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+        
+
+      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
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      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
+
+       tab_cntrl(30) = FLOAT(iday_end)
+       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
+      ENDDO
+      ENDIF
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+cIM 220306 BEG
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+#endif
+cIM 220306 END
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      endif  ! mpi_rank==0
+      RETURN
+      END
+      SUBROUTINE dynredem1_p(fichnom,time,
+     .                     vcov,ucov,teta,q,nq,masse,ps)
+      USE parallel
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+#include "advtrac.h"
+#include "temps.h"
+
+      INTEGER nq, l
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL q(ip1jmp1,llm,nq)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid
+      INTEGER ierr
+      INTEGER iq
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      call Gather_Field(ucov,ip1jmp1,llm,0)
+      call Gather_Field(vcov,ip1jm,llm,0)
+      call Gather_Field(teta,ip1jmp1,llm,0)
+      call Gather_Field(masse,ip1jmp1,llm,0)
+      call Gather_Field(ps,ip1jmp1,1,0)
+      
+      do iq=1,nq
+        call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+      enddo
+      
+      
+      if (mpi_rank==0) then
+      
+      modname = 'dynredem1'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable temps n est pas definie'
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c
+c  Re-ecriture du tableau de controle, itaufin n'est plus defini quand
+c  on passe dans dynredem0
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         abort_message="dynredem1: Le champ <controle> est absent"
+         ierr = 1
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
+#endif
+
+      IF(nq.GE.1) THEN
+       do iq=1,nq   
+        ierr = NF_INQ_VARID(nid, tname(iq), nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "Variable  tname(iq) n est pas definie"
+           CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+          ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
+#endif
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+      endif ! mpi_rank==0
+      
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ener.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ener.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ener.h	(revision 984)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'ener.h'
+
+      COMMON/ener/ang0,etot0,ptot0,ztot0,stot0,
+     *            ang,etot,ptot,ztot,stot,rmsdpdt ,
+     *            rmsv,gtot(llmm1)
+
+      REAL ang0,etot0,ptot0,ztot0,stot0,
+     s     ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot
+
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/enercin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/enercin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/enercin.F	(revision 984)
@@ -0,0 +1,98 @@
+!
+! $Header$
+!
+      SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i
+
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = iip2, ip1jm, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+
+      DO 3 i = 1, iim
+      ecinni(i) = vcov(    i  ,  l) * vcont(    i    ,l) * aire(   i   )
+      ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+   3  CONTINUE
+
+      ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+      ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+      DO 4 ij = 1,iip1
+      ecin(   ij     , l ) = ecinpn
+      ecin( ij+ ip1jm, l ) = ecinps
+   4  CONTINUE
+
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/enercin_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/enercin_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/enercin_p.F	(revision 984)
@@ -0,0 +1,121 @@
+      SUBROUTINE enercin_p ( vcov, ucov, vcont, ucont, ecin )
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i,ijb,ije
+
+      EXTERNAL    SSUM
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      IF (pole_nord) ijb=ij_begin+iip1
+      IF (pole_sud)  ije=ij_end-iip1
+      
+      DO 1  ij = ijb, ije -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = ijb, ije, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+      IF (pole_nord) THEN
+    
+        DO  i = 1, iim
+         ecinni(i) = vcov(    i  ,  l) * 
+     *               vcont(    i    ,l) * aire(   i   )
+        ENDDO
+
+        ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+
+        DO ij = 1,iip1
+          ecin(   ij     , l ) = ecinpn
+        ENDDO
+   
+      ENDIF
+
+      IF (pole_sud) THEN
+    
+        DO  i = 1, iim
+         ecinsi(i) = vcov(i+ip1jmi1,l)* 
+     *               vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+        ENDDO
+
+        ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+        DO ij = 1,iip1
+          ecin( ij+ ip1jm, l ) = ecinps
+        ENDDO
+   
+      ENDIF
+
+      
+   5  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/exner_hyb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/exner_hyb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/exner_hyb.F	(revision 984)
@@ -0,0 +1,114 @@
+!
+! $Header$
+!
+      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+c
+      
+      unpl2k    = 1.+ 2.* kappa
+c
+      DO   ij  = 1, ngrid
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+
+      DO  ij   = 1, iim
+        ppn(ij) = aire(   ij   ) * pks(  ij     )
+        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+      ENDDO
+      xpn      = SSUM(iim,ppn,1) /apoln
+      xps      = SSUM(iim,pps,1) /apols
+
+      DO ij   = 1, iip1
+        pks(   ij     )  =  xpn
+        pks( ij+ip1jm )  =  xps
+      ENDDO
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+      DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+        DO ij = 1, ngrid
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c
+      ENDDO
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+      DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+        DO   ij   = 1, ngrid
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+      ENDDO
+c
+c
+      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/exner_hyb_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/exner_hyb_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/exner_hyb_p.F	(revision 984)
@@ -0,0 +1,137 @@
+      SUBROUTINE  exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ije,ijb,jje,jjb
+c
+c$OMP MASTER           
+      unpl2k    = 1.+ 2.* kappa
+c
+      ijb=ij_begin
+      ije=ij_end
+
+
+      DO   ij  = ijb, ije
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+
+      if (pole_nord) then
+        DO  ij   = 1, iim
+          ppn(ij) = aire(   ij   ) * pks(  ij     )
+        ENDDO
+        xpn      = SSUM(iim,ppn,1) /apoln
+  
+        DO ij   = 1, iip1
+          pks(   ij     )  =  xpn
+        ENDDO
+      endif
+      
+      if (pole_sud) then
+        DO  ij   = 1, iim
+          pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+        xps      = SSUM(iim,pps,1) /apols 
+  
+        DO ij   = 1, iip1
+          pks( ij+ip1jm )  =  xps
+        ENDDO
+      endif
+
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+      DO     ij      = ijb,ije
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+        DO ij = ijb, ije
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c
+      ENDDO
+
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+
+      DO   ij   = ijb, ije
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+        DO   ij   = ijb, ije
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+      ENDDO
+c
+c
+c      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      pkf(ijb:ije,1:llm)=pk(ijb:ije,1:llm)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/extrapol.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/extrapol.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/extrapol.F	(revision 984)
@@ -0,0 +1,200 @@
+!
+! $Header$
+!
+C
+C
+      SUBROUTINE extrapol (pfild, kxlon, kylat, pmask,
+     .                   norsud, ldper, knbor, pwork)
+      IMPLICIT none
+c
+c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
+c Fill up missed values by using the neighbor points
+c
+      INTEGER kxlon, kylat ! longitude and latitude dimensions (Input)
+      INTEGER knbor ! minimum neighbor number (Input)
+      LOGICAL norsud ! True if field is from North to South (Input)
+      LOGICAL ldper ! True if take into account the periodicity (Input)
+      REAL pmask ! mask value (Input)
+      REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
+      REAL pwork(kxlon,kylat) ! working space
+c
+      REAL zwmsk
+      INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
+      INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates
+      REAL zmask(9)
+C
+C  We search over the eight closest neighbors
+C
+C            j+1  7  8  9
+C              j  4  5  6    Current point 5 --> (i,j)
+C            j-1  1  2  3
+C                i-1 i i+1
+c
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      incre = 0
+c
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         pwork(i,j) = pfild(i,j)
+      ENDDO
+      ENDDO
+c
+C* To avoid problems in floating point tests
+      zwmsk = pmask - 1.0
+c
+200   CONTINUE
+      incre = incre + 1
+      DO 99999 j = 1, kylat
+      DO 99999 i = 1, kxlon
+      IF (pfild(i,j).GT. zwmsk) THEN
+         pwork(i,j) = pfild(i,j)
+         inbor = 0
+         ideb = 1
+         ifin = 9
+C
+C* Fill up ix array
+         ix(1) = MAX (1,i-1)
+         ix(2) = i
+         ix(3) = MIN (kxlon,i+1)
+         ix(4) = MAX (1,i-1)
+         ix(5) = i
+         ix(6) = MIN (kxlon,i+1)
+         ix(7) = MAX (1,i-1)
+         ix(8) = i
+         ix(9) = MIN (kxlon,i+1)
+C
+C* Fill up iy array
+         jy(1) = MAX (1,j-1)
+         jy(2) = MAX (1,j-1)
+         jy(3) = MAX (1,j-1)
+         jy(4) = j
+         jy(5) = j
+         jy(6) = j
+         jy(7) = MIN (kylat,j+1)
+         jy(8) = MIN (kylat,j+1)
+         jy(9) = MIN (kylat,j+1)
+C
+C* Correct latitude bounds if southernmost or northernmost points
+         IF (j .EQ. 1) ideb = 4
+         IF (j .EQ. kylat) ifin = 6
+C
+C* Account for periodicity in longitude
+C
+         IF (ldper) THEN 
+            IF (i .EQ. kxlon) THEN
+               ix(3) = 1
+               ix(6) = 1
+               ix(9) = 1
+            ELSE IF (i .EQ. 1) THEN
+               ix(1) = kxlon
+               ix(4) = kxlon
+               ix(7) = kxlon
+            ENDIF
+         ELSE
+            IF (i .EQ. 1) THEN
+               ix(1) = i
+               ix(2) = i + 1
+               ix(3) = i
+               ix(4) = i + 1
+               ix(5) = i
+               ix(6) = i + 1
+            ENDIF 
+            IF (i .EQ. kxlon) THEN
+               ix(1) = i -1
+               ix(2) = i
+               ix(3) = i - 1
+               ix(4) = i
+               ix(5) = i - 1
+               ix(6) = i
+            ENDIF
+C
+            IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN 
+               jy(1) = MAX (1,j-1)
+               jy(2) = MAX (1,j-1)
+               jy(3) = j
+               jy(4) = j
+               jy(5) = MIN (kylat,j+1)
+               jy(6) = MIN (kylat,j+1)
+C
+               ideb = 1
+               ifin = 6
+               IF (j .EQ. 1) ideb = 3
+               IF (j .EQ. kylat) ifin = 4
+            ENDIF
+         ENDIF ! end for ldper test
+C
+C* Find unmasked neighbors
+C
+         DO 230 k = ideb, ifin
+            zmask(k) = 0.
+            ilon = ix(k)
+            jlat = jy(k)
+            IF (pfild(ilon,jlat) .LT. zwmsk) THEN
+               zmask(k) = 1.
+               inbor = inbor + 1
+            ENDIF
+ 230     CONTINUE
+C
+C* Not enough points around point P are unmasked; interpolation on P 
+C  will be done in a future call to extrap.
+C
+         IF (inbor .GE. knbor) THEN
+            pwork(i,j) = 0.
+            DO k = ideb, ifin
+               ilon = ix(k)
+               jlat = jy(k)
+               pwork(i,j) = pwork(i,j)
+     $                      + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor)
+            ENDDO
+         ENDIF
+C
+      ENDIF
+99999 CONTINUE
+C
+C*    3. Writing back unmasked field in pfild
+C        ------------------------------------
+C
+C* pfild then contains:
+C     - Values which were not masked
+C     - Interpolated values from the inbor neighbors
+C     - Values which are not yet interpolated
+C
+      idoit = 0
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1
+         pfild(i,j) = pwork(i,j)
+      ENDDO
+      ENDDO
+c
+      IF (idoit .ne. 0) GOTO 200
+ccc      PRINT*, "Number of extrapolation steps incre =", incre
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/filtreg_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/filtreg_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/filtreg_p.F	(revision 984)
@@ -0,0 +1,303 @@
+      SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, 
+     .                       ifiltre, iaire, griscal ,iter)
+      USE Parallel, only : OMP_CHUNK 
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van        07/10/97
+c   ------
+c
+c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+c                     pour l'operateur  Filtre    .
+c   ------
+c
+c   Arguments:
+c   ----------
+c
+c      
+c      ibeg..iend            lattitude a filtrer
+c      nlat                  nombre de latitudes du champ
+c      nbniv                 nombre de niveaux verticaux a filtrer
+c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+c                            en sortie : champ filtre
+c      ifiltre               +1  Transformee directe
+c                            -1  Transformee inverse
+c                            +2  Filtre directe
+c                            -2  Filtre inverse
+c
+c      iaire                 1   si champ intensif
+c                            2   si champ extensif (pondere par les aires)
+c
+c      iter                  1   filtre simple
+c
+c=======================================================================
+c
+c
+c                      Variable Intensive
+c                ifiltre = 1     filtre directe
+c                ifiltre =-1     filtre inverse
+c
+c                      Variable Extensive
+c                ifiltre = 2     filtre directe
+c                ifiltre =-2     filtre inverse
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "parafilt.h"
+#include "coefils.h"
+c
+      INTEGER ibeg,iend,nlat,nbniv,ifiltre,iter
+      INTEGER i,j,l,k
+      INTEGER iim2,immjm
+      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+      REAL  champ( iip1,nlat,nbniv)
+      REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs
+      COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus)
+     ,             , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs)
+     ,             ,  matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus)
+      REAL  eignq(iim), sdd1(iim),sdd2(iim)
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+c
+
+      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
+     *    STOP'Pas de transformee simple dans cette version'
+
+      IF( iter.EQ. 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'
+     * , ' Utiliser old_filtreg et repasser !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ',
+     * ' sur la grille des scalaires !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     *,' corriger et repasser !'
+           STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+             PRINT  1111
+             STOP
+         ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 2
+             jffil1 = jfiltnu
+             jdfil2 = jfiltsu
+             jffil2 = jjm
+          END IF
+      ELSE
+          IF( nlat.NE.jjm )  THEN
+             PRINT  2222
+             STOP
+          ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 1
+             jffil1 = jfiltnv
+             jdfil2 = jfiltsv
+             jffil2 = jjm
+          END IF
+      END IF
+c
+c
+      DO 100  hemisph = 1, 2
+c
+      IF ( hemisph.EQ.1 )  THEN
+c ym
+          jdfil = max(jdfil1,ibeg)
+          jffil = min(jffil1,iend)
+      ELSE
+c ym
+          jdfil = max(jdfil2,ibeg)
+          jffil = min(jffil2,iend)
+      END IF
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO 50  l = 1, nbniv
+      DO 30  j = jdfil,jffil
+ 
+ 
+      DO  5  i = 1, iim
+      champ(i,j,l) = champ(i,j,l) * sdd1(i)
+   5  CONTINUE
+c
+
+      IF( hemisph. EQ. 1 )      THEN
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvn(1,1,j), 1, iim, champ(1,j,l), 1, eignq  , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO k = 1, iim
+      DO i = 1, iim
+         eignq(k) = eignq(k) + matrinvn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceun(1,1,j), 1, iim, champ(1,j,l), 1, eignq ,
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceun(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceun(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevn(1,1,j), 1, iim, champ(1,j,l), 1, eignq , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ELSE
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvs(1,1,j-jfiltsu+1),  1, iim, champ(1,j,l),1 ,  
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvs(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matrinvs(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceus(1,1,j-jfiltsu+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceus(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceus(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevs(1,1,j-jfiltsv+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevs(1,1,j-jfiltsv+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevs(k,i,j-jfiltsv+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ENDIF
+c
+      IF( ifiltre.EQ. 2 )  THEN
+        DO 15 i = 1, iim
+        champ( i,j,l ) = ( champ(i,j,l) + eignq(i) ) * sdd2(i)
+  15    CONTINUE
+      ELSE
+        DO 16 i=1,iim
+        champ( i,j,l ) = ( champ(i,j,l) - eignq(i) ) * sdd2(i)
+16      CONTINUE
+      ENDIF
+c
+      champ( iip1,j,l ) = champ( 1,j,l )
+c
+  30  CONTINUE
+c
+  50  CONTINUE
+c$OMP END DO NOWAIT
+c    
+ 100  CONTINUE
+c
+1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
+     *filtrer, sur la grille des scalaires'/)
+2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
+     *ltrer, sur la grille de V ou de Z'/)
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/flumass_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/flumass_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/flumass_p.F	(revision 984)
@@ -0,0 +1,152 @@
+      SUBROUTINE flumass_p(massebx,masseby, vcont, ucont, pbaru, pbarv)
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
+     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
+     * pbarv( ip1jm,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+      INTEGER ijb,ije
+      
+      EXTERNAL   SSUM
+      REAL       SSUM
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO  5 l = 1,llm
+
+        ijb=ij_begin
+        ije=ij_end+iip1
+      
+        if (pole_nord) ijb=ij_begin+iip1
+        if (pole_sud)  ije=ij_end-iip1
+        
+        DO  1 ij = ijb,ije
+          pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1    CONTINUE
+
+        ijb=ij_begin-iip1
+        ije=ij_end+iip1
+      
+        if (pole_nord) ijb=ij_begin
+        if (pole_sud)  ije=ij_end-iip1
+        
+        DO 3 ij = ijb,ije
+          pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3    CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      IF (pole_nord) THEN
+     
+        sairen = SSUM( iim,  aire(   1     ), 1 )
+        saireun= SSUM( iim, aireu(   1     ), 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+        DO l = 1,llm
+ 
+          ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      
+          pbaru(1,l)=pbarv(1,l) - ctn * aire(1)
+        
+          DO i = 2,iim
+            pbaru(i,l) = pbaru(i- 1,l )    +
+     *                   pbarv(i,l) - ctn * aire(i )
+          ENDDO
+        
+          DO i = 1,iim
+            apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+          ENDDO
+      
+          ctn0 = -SSUM( iim,apbarun,1 )/saireun
+        
+          DO i = 1,iim
+            pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+          ENDDO
+       
+          pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+        
+        ENDDO
+c$OMP END DO NOWAIT              
+
+      ENDIF
+
+      
+      IF (pole_sud) THEN
+  
+        saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+        saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+        DO  l = 1,llm
+ 
+          cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+          pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1)
+   
+          DO i = 2,iim
+            pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l)    -
+     *                          pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
+          ENDDO
+        
+          DO i = 1,iim
+            apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+          ENDDO
+
+          cts0 = -SSUM( iim,apbarus,1 )/saireus
+
+          DO i = 1,iim
+            pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+          ENDDO
+
+          pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+       
+        ENDDO
+c$OMP END DO NOWAIT         
+      ENDIF
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/fluxstokenc_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/fluxstokenc_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/fluxstokenc_p.F	(revision 984)
@@ -0,0 +1,232 @@
+      SUBROUTINE fluxstokenc_p(pbaru,pbarv,masse,teta,phi,phis,
+     . time_step,itau )
+
+       USE IOIPSL
+       USE parallel
+       USE misc_mod
+       USE mod_hallo
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "tracstoke.h"
+#include "temps.h"
+
+      REAL time_step,t_wrt, t_ops
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+      REAL phis(ip1jmp1)
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
+
+      REAL pbarvst(iip1,jjp1,llm),zistdyn
+	real dtcum
+
+      INTEGER iadvtr,ndex(1) 
+      integer nscal
+      real tst(1),ist(1),istp(1)
+      INTEGER ij,l,irec,i,j,itau
+      INTEGER,SAVE :: fluxid, fluxvid,fluxdid
+ 
+      SAVE iadvtr, massem,pbaruc,pbarvc,irec
+      SAVE phic,tetac
+      logical first
+      save first
+      data first/.true./
+      DATA iadvtr/0/
+      integer :: ijb,ije,jjb,jje,jjn
+      type(Request) :: Req
+
+c AC initialisations
+cym      pbarug(:,:)   = 0.
+cym      pbarvg(:,:,:) = 0.
+cym      wg(:,:)       = 0.
+
+      if(first) then
+
+	CALL initfluxsto_p( 'fluxstoke',
+     .  time_step,istdyn* time_step,istdyn* time_step,
+     . nqmx, fluxid,fluxvid,fluxdid) 
+	
+        ijb=ij_begin
+        ije=ij_end
+        jjn=jj_nb
+
+	ndex(1) = 0
+        call histwrite(fluxid, 'phis', 1, phis(ijb:ije),
+     .	               iip1*jjn, ndex)
+        call histwrite(fluxid, 'aire', 1, aire(ijb:ije),
+     .                 iip1*jjn, ndex)
+	
+	ndex(1) = 0
+        nscal = 1
+        
+	if (mpi_rank==0) then
+          tst(1) = time_step
+          call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
+          ist(1)=istdyn
+          call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
+          istp(1)= istphy
+          call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
+	endif
+	first = .false.
+
+      endif
+
+
+      IF(iadvtr.EQ.0) THEN
+cym         CALL initial0(ijp1llm,phic)
+cym        CALL initial0(ijp1llm,tetac)
+cym         CALL initial0(ijp1llm,pbaruc)
+cym         CALL initial0(ijmllm,pbarvc)
+        ijb=ij_begin
+        ije=ij_end
+        phic(ijb:ije,1:llm)=0
+	tetac(ijb:ije,1:llm)=0
+	pbaruc(ijb:ije,1:llm)=0
+	
+	if (pole_sud) ije=ij_end-iip1
+	pbarvc(ijb:ije,1:llm)=0
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,llm
+         DO ij = ijb,ije
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+            phic(ij,l) = phic(ij,l) + phi(ij,l)
+         ENDDO
+       ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud) ije=ij_end-iip1
+	
+      DO l=1,llm
+         DO ij = ijb,ije
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+cym         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+        ijb=ij_begin
+        ije=ij_end 
+	massem(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.istdyn ) THEN
+c    normalisation
+      ijb=ij_begin
+      ije=ij_end 
+
+      DO l=1,llm
+         DO ij = ijb,ije
+            pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
+            tetac(ij,l) = tetac(ij,l)/float(istdyn)
+            phic(ij,l) = phic(ij,l)/float(istdyn)
+         ENDDO
+      ENDDO
+
+      ijb=ij_begin
+      ije=ij_end 
+      if (pole_sud) ije=ij_end-iip1      
+      
+      DO l=1,llm
+          DO ij = ijb,ije
+            pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
+         ENDDO
+      ENDDO
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        call Register_Hallo(pbaruc,ip1jmp1,llm,1,1,1,1,Req)
+	call Register_Hallo(pbarvc,ip1jm,llm,1,1,1,1,Req)
+        call SendRequest(Req)
+        call WaitRequest(Req)
+
+        CALL groupe_p( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+        
+        jjb=jj_begin
+	jje=jj_end
+	if (pole_sud) jje=jj_end-1
+	
+        do l=1,llm
+           do j=jjb,jje
+              do i=1,iip1
+                 pbarvst(i,j,l)=pbarvg(i,j,l)
+              enddo
+           enddo
+	 enddo
+	 
+	 if (pole_sud) then
+           do i=1,iip1
+              pbarvst(i,jjp1,l)=0.
+           enddo
+        endif
+      
+         iadvtr=0
+	Print*,'ITAU auqel on stoke les fluxmasses',itau
+	
+        ijb=ij_begin
+	ije=ij_end
+	jjn=jj_nb
+	
+	call histwrite(fluxid, 'masse', itau, massem(ijb:ije,:),
+     .               iip1*jjn*llm, ndex)
+	
+	call histwrite(fluxid, 'pbaru', itau, pbarug(ijb:ije,:),
+     .               iip1*jjn*llm, ndex)
+	
+        jjb=jj_begin
+	jje=jj_end
+	jjn=jj_nb
+	if (pole_sud) then
+	  jje=jj_end-1
+	  jjn=jj_nb-1
+	endif
+	
+	call histwrite(fluxvid, 'pbarv', itau, pbarvg(:,jjb:jje,:),
+     .               iip1*jjn*llm, ndex)
+	
+        ijb=ij_begin
+	ije=ij_end
+	jjn=jj_nb
+	
+        call histwrite(fluxid, 'w' ,itau, wg(ijb:ije,:), 
+     .             iip1*jjn*llm, ndex) 
+	
+	call histwrite(fluxid, 'teta' ,itau, tetac(ijb:ije,:), 
+     .             iip1*jjn*llm, ndex) 
+	
+	call histwrite(fluxid, 'phi' ,itau, phic(ijb:ije,:), 
+     .             iip1*jjn*llm, ndex) 
+	
+C
+
+      ENDIF ! if iadvtr.EQ.istdyn
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/friction_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/friction_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/friction_p.F	(revision 984)
@@ -0,0 +1,143 @@
+!
+! $Header$
+!
+c=======================================================================
+      SUBROUTINE friction_p(ucov,vcov,pdt)
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c
+c   Objet:
+c   ------
+c
+c  ***********
+c    Friction
+c  ***********
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "comconst.h"
+
+      REAL pdt
+      REAL modv(iip1,jjp1),zco,zsi
+      REAL vpn,vps,upoln,upols,vpols,vpoln
+      REAL u2(iip1,jjp1),v2(iip1,jjm)
+      REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm )
+      INTEGER  i,j
+      REAL cfric
+      parameter (cfric=1.e-5)
+      integer :: jjb,jje
+
+
+c   calcul des composantes au carre du vent naturel
+      jjb=jj_begin
+      jje=jj_end+1
+      if (pole_sud) jje=jj_end
+      
+      do j=jjb,jje
+         do i=1,iip1
+            u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+         enddo
+      enddo
+      
+      jjb=jj_begin-1
+      jje=jj_end+1
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud) jje=jj_end-1
+      
+      do j=jjb,jje
+         do i=1,iip1
+            v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+         enddo
+      enddo
+
+c   calcul du module de V en dehors des poles
+      jjb=jj_begin
+      jje=jj_end+1
+      if (pole_nord) jjb=jj_begin+1
+      if (pole_sud) jje=jj_end-1
+      
+      do j=jjb,jje
+         do i=2,iip1
+            modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+         enddo
+         modv(1,j)=modv(iip1,j)
+      enddo
+
+c   les deux composantes du vent au pole sont obtenues comme
+c   premiers modes de fourier de v pres du pole
+      if (pole_nord) then
+      
+        upoln=0.
+        vpoln=0.
+     
+        do i=2,iip1
+           zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+           zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+           vpn=vcov(i,1,1)/cv(i,1)
+           upoln=upoln+zco*vpn
+           vpoln=vpoln+zsi*vpn
+        enddo
+        vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+        do i=1,iip1
+c          modv(i,1)=vpn
+           modv(i,1)=modv(i,2)
+        enddo
+
+      endif
+      
+      if (pole_sud) then
+      
+        upols=0.
+        vpols=0.
+        do i=2,iip1
+           zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+           zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+           vps=vcov(i,jjm,1)/cv(i,jjm)
+           upols=upols+zco*vps
+           vpols=vpols+zsi*vps
+        enddo
+        vps=sqrt(upols*upols+vpols*vpols)/pi
+        do i=1,iip1
+c        modv(i,jjp1)=vps
+         modv(i,jjp1)=modv(i,jjm)
+        enddo
+      
+      endif
+      
+c   calcul du frottement au sol.
+
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_nord) jjb=jj_begin+1
+      if (pole_sud) jje=jj_end-1
+
+      do j=jjb,jje
+         do i=1,iim
+            ucov(i,j,1)=ucov(i,j,1)
+     s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+         enddo
+         ucov(iip1,j,1)=ucov(1,j,1)
+      enddo
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      
+      do j=jjb,jje
+         do i=1,iip1
+            vcov(i,j,1)=vcov(i,j,1)
+     s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+         enddo
+         vcov(iip1,j,1)=vcov(1,j,1)
+      enddo
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxhyp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxhyp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxhyp.F	(revision 984)
@@ -0,0 +1,448 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
+
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+c    Calcule les longitudes et derivees dans la grille du GCM pour une
+c     fonction f(x) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
+c     dzoom  etant  la distance totale de la zone du zoom
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
+c
+c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
+c   ********************************************************************
+
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+       LOGICAL scal180
+       PARAMETER ( scal180 = .TRUE. )
+
+c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
+c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
+c      sinon scal180 = .FALSE.
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,dzooma,tau,grossism
+
+c    ......   arguments  de  sortie  ......
+
+       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
+     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
+
+c     .... variables locales  ....
+c
+       REAL   dzoom
+       REAL*8 xlon(iip1),xprimm(iip1),xuv
+       REAL*8 xtild(0:nmax2)
+       REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
+       REAL*8 Xf(0:nmax2),xxpr(0:nmax2)
+       REAL*8 xvrai(iip1),xxprim(iip1) 
+       REAL*8 pi,depi,epsilon,xzoom,fa,fb
+       REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2
+       INTEGER i,it,ik,iter,ii,idif,ii1,ii2
+       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL*8 champmin,champmax,decalx
+       INTEGER is2
+       SAVE is2
+
+       REAL*8 heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-3
+       xzoom    = xzoomdeg * pi/180. 
+c
+           decalx   = .75
+       IF( grossism.EQ.1..AND.scal180 )  THEN
+           decalx   = 1.
+       ENDIF
+
+       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
+c
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * depi
+       ELSEIF( dzooma.LT. 25. ) THEN
+         WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) xzoom,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        xtild(i) = - pi + FLOAT(i) * depi /nmax2
+       ENDDO
+
+       DO i = nmax, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fhyp ( i ) = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fhyp ( i )  =   1.
+                ENDIF
+            ELSE
+                    fhyp ( i )  =  TANH ( fa/fb )
+            ENDIF
+         ENDIF
+        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
+        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+
+       ffdx = 0.
+
+       DO i = nmax +1,nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fxm   = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fxm   =   1.
+                ENDIF
+            ELSE
+                    fxm   =  TANH ( fa/fb )
+            ENDIF
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm  =  1.
+       IF ( xmoy.EQ. pi )  fxm  = -1.
+
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT
+       ENDIF
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = nmax, nmax2
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i =  nmax+1, nmax2
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+       Xf(0) = - pi
+
+       DO i =  nmax +1, nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm =  1.
+       IF ( xmoy.EQ. pi )  fxm = -1.
+       xxpr(i)    = beta + ( grossism - beta ) * fxm
+
+       ENDDO
+
+       DO i = nmax+1, nmax2
+        xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1, 4
+
+       IF( ik.EQ.1 )        THEN
+         xuv =  -0.25
+       ELSE IF ( ik.EQ.2 )  THEN
+         xuv =   0.
+       ELSE IF ( ik.EQ.3 )  THEN
+         xuv =   0.50
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+      xo1   = 0.
+
+      ii1=1
+      ii2=iim
+      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
+        ii1 = 2 
+        ii2 = iim+1
+      ENDIF
+      DO 1500 i = ii1, ii2
+
+      xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim) 
+
+      Xfi    = xlon2
+c
+      DO 250 it =  nmax2,0,-1
+      IF( Xfi.GE.Xf(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+
+350   CONTINUE
+
+c    ......  Calcul de   Xf(xi)    ...... 
+c
+      xi  = xtild(it)
+
+      IF(it.EQ.nmax2)  THEN
+       it       = nmax2 -1
+       Xf(it+1) = pi
+      ENDIF
+c  .....................................................................
+c
+c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
+c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
+c          et (Xf(it+1),xtild(it+1) )
+
+       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
+     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
+
+       Xf1     = Xf(it)
+       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
+
+       DO 500 iter = 1,300
+        xi = xi - ( Xf1 - Xfi )/ Xprimin
+
+        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
+         xo1      = xi
+         xi2      = xi * xi
+         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
+         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
+550   CONTINUE
+
+       xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
+
+1500   CONTINUE
+
+
+       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
+         xvrai(1)    = xvrai(iip1)-depi
+         xxprim(1)   = xxprim(iip1)
+       ENDIF
+       DO i = 1 , iim
+        xlon(i)     = xvrai(i)
+        xprimm(i)   = xxprim(i)
+       ENDDO
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
+        ENDIF
+       ENDDO
+c
+c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
+c   ........................................................................
+
+       champmin =  1.e12
+       champmax = -1.e12
+       DO i = 1, iim
+        champmin = MIN( champmin,xvrai(i) )
+        champmax = MAX( champmax,xvrai(i) )
+       ENDDO
+
+      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
+                GO TO 1600
+      ELSE
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
+ 80       CONTINUE
+          is2 = i
+          ENDIF
+
+          IF( is2.NE. 1 )  THEN
+            DO ii = is2 , iim
+             xlon  (ii-is2+1) = xvrai(ii)
+             xprimm(ii-is2+1) = xxprim(ii)
+            ENDDO
+            DO ii = 1 , is2 -1
+             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
+             xprimm(ii+iim-is2+1) = xxprim(ii) 
+            ENDDO
+          ENDIF
+        ELSE 
+          IF( ik.EQ.1 )  THEN
+           DO i = iim,1,-1
+             IF( xvrai(i).LE. pi ) GO TO 90
+           ENDDO
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+           idif = iim -is2
+           DO ii = 1, is2
+            xlon  (ii+idif) = xvrai(ii)
+            xprimm(ii+idif) = xxprim(ii)
+           ENDDO
+           DO ii = 1, idif
+            xlon (ii)  = xvrai (ii+is2) - depi
+            xprimm(ii) = xxprim(ii+is2) 
+           ENDDO
+         ENDIF
+      ENDIF
+c
+c     .........   Fin  de la reorganisation   ............................
+
+ 1600    CONTINUE
+
+
+         xlon  ( iip1)  = xlon(1) + depi
+         xprimm( iip1 ) = xprimm (1 )
+       
+         DO i = 1, iim+1
+         xvrai(i) = xlon(i)*180./pi
+         ENDDO
+
+         IF( ik.EQ.1 )  THEN
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim +1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.2 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.3)   THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.4 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+
+         ENDIF
+
+5000    CONTINUE
+c
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+18     FORMAT(/)
+24     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
+68     FORMAT(1x,7f9.2)
+566    FORMAT(1x,7f9.4)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxy.F	(revision 984)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+      IMPLICIT NONE
+
+c     Auteur  :  P. Le Van
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c           a tangente sinusoidale et eventuellement avec zoom  .
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "serre.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_new.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( FLOAT( j )        )
+         yprimu(j) = fyprim( FLOAT( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
+         rlatu1(j) = fy    ( FLOAT( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( FLOAT( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( FLOAT( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
+        yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   FLOAT( i )          )
+           rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
+        rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
+        rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  FLOAT( i )          )
+         xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxyhyper.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxyhyper.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxyhyper.F	(revision 984)
@@ -0,0 +1,139 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy  ,   
+     ,                       xzoom, grossx, dzoomx,taux  ,
+     , rlatu,yprimu,rlatv,yprimv,rlatu1,  yprimu1,  rlatu2,  yprimu2  , 
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       IMPLICIT NONE
+c
+c      Auteur :  P. Le Van .
+c
+c      d'apres  formulations de R. Sadourny .
+c
+c
+c     Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp )
+c            par des  fonctions  a tangente hyperbolique .
+c
+c     Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom
+c                      et  yzoom )   :  
+c
+c     a) le grossissement du zoom  :  grossy  ( en y ) et grossx ( en x )
+c     b) l' extension     du zoom  :  dzoomy  ( en y ) et dzoomx ( en x )
+c     c) la raideur de la transition du zoom  :   taux et tauy   
+c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+
+c   .....  Arguments  ...
+c
+       REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+       REAL*8  dxmin, dxmax , dymin, dymax
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy  , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  dymin,dymax                                               )
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax         )
+
+
+        DO i = 1, iip1
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         STOP 13
+       ENDIF
+c
+       IF(rlatu2(j).LE.rlatu(j+1))  THEN
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FY **** '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Latitudes  '
+        WRITE(6,*) ' *********** '
+        WRITE(6,18)
+        WRITE(6,3)  dymin, dymax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Longitudes  '
+        WRITE(6,*) ' ************ '
+        WRITE(6,18)
+        WRITE(6,3)  dxmin, dxmax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+        WRITE(6,18)
+c
+3      Format(1x, ' Au centre du zoom , la longueur de la maille est',
+     ,  ' d environ ',f8.2 ,' degres  ',
+     , ' alors que la maille en dehors de la zone du zoom est d environ
+     , ', f8.2,' degres ' )
+18      FORMAT(/)
+
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxysinus.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxysinus.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/fxysinus.F	(revision 984)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+
+      IMPLICIT NONE
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c            avec y = Asin( j )  .
+c
+c     Auteur  :  P. Le Van
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_sin.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( FLOAT( j )        )
+         yprimu(j) = fyprim( FLOAT( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
+         rlatu1(j) = fy    ( FLOAT( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( FLOAT( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( FLOAT( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
+        yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   FLOAT( i )          )
+           rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
+        rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
+        rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  FLOAT( i )          )
+         xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/fyhyp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/fyhyp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/fyhyp.F	(revision 984)
@@ -0,0 +1,378 @@
+!
+! $Header$
+!
+c
+c
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau  ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  champmin,champmax                                            ) 
+
+cc    ...  Version du 01/04/2001 ....
+
+       IMPLICIT NONE
+c
+c    ...   Auteur :  P. Le Van  ... 
+c
+c    .......    d'apres  formulations  de R. Sadourny  .......
+c
+c     Calcule les latitudes et derivees dans la grille du GCM pour une
+c     fonction f(y) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc)
+c     dzoom  etant  la distance totale de la zone du zoom ( en radians )
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom   
+c
+c
+c N.B : Il vaut mieux avoir : grossism * dzoom  <  pi/2  (radians) ,en lati.
+c      ********************************************************************
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzooma,tau 
+c         ( rentres  par  run.def )
+
+c     .......  arguments  de sortie   .......
+c
+       REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+
+c
+c     .....     champs  locaux    .....
+c
+     
+       REAL   dzoom
+       REAL*8 ylat(jjp1), yprim(jjp1)
+       REAL*8 yuv
+       REAL*8 yt(0:nmax2)
+       REAL*8 fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2)
+       SAVE Ytprim, yt,Yf
+       REAL*8 Yf(0:nmax2),yypr(0:nmax2)
+       REAL*8 yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL*8 pi,depi,pis2,epsilon,y0,pisjm
+       REAL*8 yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax
+       REAL*8 yfi,Yf1,ffdy
+       REAL*8 ypn,deply,y00
+       SAVE y00, deply
+
+       INTEGER i,j,it,ik,iter,jlat
+       INTEGER jpn,jjpn
+       SAVE jpn
+       REAL*8 a0,a1,a2,a3,yi2,heavyy0,heavyy0m
+       REAL*8 fa(0:nmax2),fb(0:nmax2)
+       REAL y0min,y0max
+
+       REAL*8     heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       pis2     = pi/2.
+       pisjm    = pi/ FLOAT(jjm)
+       epsilon  = 1.e-3
+       y0       =  yzoomdeg * pi/180. 
+
+       IF( dzooma.LT.1.)  THEN
+         dzoom = dzooma * pi
+       ELSEIF( dzooma.LT. 12. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzooma * pi/180.
+       ENDIF
+
+       WRITE(6,18)
+       WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) y0,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        yt(i) = - pis2  + FLOAT(i)* pi /nmax2
+       ENDDO
+
+       heavyy0m = heavyside( -y0 )
+       heavyy0  = heavyside(  y0 )
+       y0min    = 2.*y0*heavyy0m - pis2
+       y0max    = 2.*y0*heavyy0  + pis2
+
+       fa = 999.999
+       fb = 999.999
+       
+       DO i = 0, nmax2 
+        IF( yt(i).LT.y0 )  THEN
+         fa (i) = tau*  (yt(i)-y0+dzoom/2. )
+         fb(i) =   (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) )
+        ELSEIF ( yt(i).GT.y0 )  THEN
+         fa(i) =   tau *(y0-yt(i)+dzoom/2. )
+         fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) 
+       ENDIF
+        
+       IF( 200.* fb(i) .LT. - fa(i) )   THEN
+         fhyp ( i) = - 1.
+       ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fhyp ( i) =   1.
+       ELSE  
+         fhyp(i) =  TANH ( fa(i)/fb(i) )
+       ENDIF
+
+       IF( yt(i).EQ.y0 )  fhyp(i) = 1.
+       IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT
+
+       ENDIF
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax2
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+
+c   .....  Calcul  de  Yf     ........
+
+       Yf(0) = - pis2
+       DO i = 1, nmax2
+        yypr(i)    = beta + ( grossism - beta ) * fxm(i)
+       ENDDO
+
+       DO i=1,nmax2
+        Yf(i)   = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) )
+       ENDDO
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1,4
+
+       IF( ik.EQ.1 )  THEN
+         yuv  = 0.
+         jlat = jjm + 1
+       ELSE IF ( ik.EQ.2 )  THEN
+         yuv  = 0.5
+         jlat = jjm 
+       ELSE IF ( ik.EQ.3 )  THEN
+         yuv  = 0.25
+         jlat = jjm 
+       ELSE IF ( ik.EQ.4 )  THEN
+         yuv  = 0.75
+         jlat = jjm 
+       ENDIF
+c
+       yo1   = 0.
+       DO 1500 j =  1,jlat
+        yo1   = 0.
+        ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
+       DO 250 it =  nmax2,0,-1
+        IF( yfi.GE.Yf(it))  GO TO 350
+250    CONTINUE
+       it = 0
+350    CONTINUE
+
+       yi = yt(it)
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = pis2
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1),   
+     ,                  yt(it),yt(it+1) ,   a0,a1,a2,a3   )      
+
+       Yf1     = Yf(it)
+       Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi
+
+       DO 500 iter = 1,300
+         yi = yi - ( Yf1 - yfi )/ Yprimin
+
+        IF( ABS(yi-yo1).LE.epsilon)  GO TO 550
+         yo1      = yi
+         yi2      = yi * yi
+         Yf1      = a0 +  a1 * yi +     a2 * yi2  +     a3 * yi2 * yi
+         Yprimin  =       a1      + 2.* a2 *  yi  + 3.* a3 * yi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
+550   CONTINUE
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
+
+1500    CONTINUE
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         WRITE(6,*) ' PBS. avec  rlat(',j+1,') plus petit que rlat(',j,
+     ,  ')'
+         STOP 3
+        ENDIF
+       ENDDO
+
+       WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2'
+     , ,' et  pi/2 '
+c
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 
+          DO j = jlat,1,-1
+           IF( yvrai(j).LE. ypn ) GO TO 1502
+          ENDDO
+1502     CONTINUE
+
+         jpn   = j
+         y00   = yvrai(jpn)
+         deply = pis2 -  y00
+        ENDIF
+
+         DO  j = 1, jjm +1 - jpn
+           ylatt (j)  = -pis2 - y00  + yvrai(jpn+j-1)
+           yprimm(j)  = yprim(jpn+j-1)
+         ENDDO
+
+         jjpn  = jpn
+         IF( jlat.EQ. jjm ) jjpn = jpn -1
+
+         DO j = 1,jjpn 
+          ylatt (j + jjm+1 -jpn) = yvrai(j) + deply
+          yprimm(j + jjm+1 -jpn) = yprim(j)
+         ENDDO
+
+c      ***********   Fin de la reorganisation     *************
+c
+ 1600   CONTINUE
+
+       DO j = 1, jlat
+          ylat(j) =  ylatt( jlat +1 -j )
+         yprim(j) = yprimm( jlat +1 -j )
+       ENDDO
+  
+        DO j = 1, jlat
+         yvrai(j) = ylat(j)*180./pi
+        ENDDO
+
+        IF( ik.EQ.1 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U   apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 2 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*) ' YLAT   en V  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*)' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 3 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U + 0.75  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT en U + 0.25  apres ( en  deg. ) '
+c         WRITE(6,68)(yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,68) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+
+        ENDIF
+
+5000   CONTINUE
+c
+        WRITE(6,18)
+c
+c  .....     fin de la boucle  do 5000 .....
+
+        DO j = 1, jjm
+         ylat(j) = rrlatu(j) - rrlatu(j+1)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO j = 1, jjm
+         champmin = MIN( champmin, ylat(j) )
+         champmax = MAX( champmax, ylat(j) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+24     FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3)
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gcm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gcm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gcm.F	(revision 984)
@@ -0,0 +1,453 @@
+!
+! $Header$
+!
+c
+c
+      PROGRAM gcm
+
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#endif
+      USE mod_const_mpi, ONLY: init_const_mpi
+      USE parallel
+      USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb
+      USE mod_grid_phy_lmdz
+      USE dimphy
+      USE mod_interface_dyn_phys
+      USE comgeomphy
+      USE mod_hallo
+      USE Bands
+      USE Write_Field
+      USE Write_Field_phy
+      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 'mpif.h'
+#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"
+#include "advtrac.h"
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+      SAVE  clesphy0
+
+
+
+      REAL zdtvr
+c      INTEGER nbetatmoy, nbetatdem,nbetat
+      INTEGER nbetatmoy, nbetatdem
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+c      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+c      REAL pks(ip1jmp1)                      ! exner au  sol
+c      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+c      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! 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
+c      INTEGER ij,iq,l,i,j
+      INTEGER i,j
+
+
+      real time_step, t_wrt, t_ops
+
+c      REAL rdayvrai,rdaym_ini,rday_ecri
+c      LOGICAL first
+
+      LOGICAL call_iniphys
+      data call_iniphys/.true./
+
+c      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+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
+
+C Calendrier
+      LOGICAL true_calendar
+      PARAMETER (true_calendar = .false.)
+
+c-----------------------------------------------------------------------
+c    variables pour l'initialisation de la physique :
+c    ------------------------------------------------
+      INTEGER ngridmx,nq
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx)
+      REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
+      
+      INTEGER :: ierr
+
+
+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 initialisation Anne
+      hadv_flg(:) = 0.
+      vadv_flg(:) = 0.
+      conv_flg(:) = 0.
+      pbl_flg(:)  = 0. 
+      tracnam(:)  = '        ' 
+      nprath = 1
+      nbtrac = 0
+      mmt_adj(:,:,:,:) = 1
+
+
+c--------------------------------------------------------------------------
+c   Iflag_phys controle l'appel a la physique :
+c   -------------------------------------------
+c      0 : pas de physique
+c      1 : Normale (appel a phylmd, phymars ...)
+c      2 : rappel Newtonien pour la temperature + friction au sol
+      iflag_phys=1
+
+c--------------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+c     T : on lit start.nc
+c     F : le modele s'autoinitialise avec un cas academique (iniacademic)
+#ifdef CPP_IOIPSL
+      read_start=.true.
+#else
+      read_start=.false.
+#endif
+
+c-----------------------------------------------------------------------
+c   Choix du calendrier
+c   -------------------
+
+#ifdef CPP_IOIPSL
+      if (true_calendar) then
+        call ioconf_calendar('gregorian')
+      else
+        call ioconf_calendar('360d')
+      endif
+#endif
+c----------------------------------------------------------------------
+c  lecture des fichiers gcm.def ou run.def
+c  ---------------------------------------
+c
+#ifdef CPP_IOIPSL
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+#else
+      CALL defrun( 99, .TRUE. , clesphy0 )
+#endif
+c
+c
+c------------------------------------
+c   Initialisation partie parallele
+c------------------------------------
+      CALL init_const_mpi
+
+      call init_parallel
+      call Read_Distrib
+      CALL Init_Phys_lmdz(iim,jjp1,llm,nqmx-2,mpi_size,distrib_phys)
+      CALL set_bands
+      CALL Init_interface_dyn_phys
+      call MPI_BARRIER(COMM_LMDZ,ierr)
+      if (mpi_rank==0) call WriteBands
+      call SetDistrib(jj_Nb_Caldyn)
+      call Init_Mod_hallo
+
+c$OMP PARALLEL
+      call InitComgeomphy
+c$OMP END PARALLEL 
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         call init_const_lmdz(nbtrac,anneeref,dayref,iphysiq,day_step,nday)
+         call init_inca_para(iim,jjm+1,klon_glo,mpi_size,klon_mpi_para_nb,
+     $        COMM_LMDZ)
+#endif
+      END IF
+
+c-----------------------------------------------------------------------
+c   Initialisation des traceurs
+c   ---------------------------
+c  Choix du schema pour l'advection
+c  dans fichier trac.def ou via INCA
+
+       call iniadvtrac(nq)
+c
+c-----------------------------------------------------------------------
+c   Lecture de l'etat initial :
+c   ---------------------------
+
+c  lecture du fichier start.nc
+      if (read_start) then
+#ifdef CPP_IOIPSL
+         CALL dynetat0("start.nc",nqmx,vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+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
+      endif
+
+      IF (config_inca /= 'none') 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,*)
+     .                 'AVANT iniacademic AVANT AVANT AVANT AVANT'
+      if (.not.read_start) then
+         CALL iniacademic(nqmx,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/FLOAT(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         WRITE(lunout,*)
+     .    'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+C
+C on remet le calendrier à zero si demande
+c
+      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+        write(lunout,*)
+     .  ' Attention les dates initiales lues dans le fichier'
+        write(lunout,*)
+     .  ' restart ne correspondent pas a celles lues dans '
+        write(lunout,*)' gcm.def'
+        if (raz_date .ne. 1) then
+          write(lunout,*)
+     .    ' 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,*)
+     .   ' On reinitialise a la date lue dans gcm.def'
+        endif
+      ELSE
+        raz_date = 0
+      endif
+
+
+c  nombre d'etats dans les fichiers demarrage et histoire
+      nbetatdem = nday / iecri
+      nbetatmoy = nday / periodav + 1
+
+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
+c
+c-----------------------------------------------------------------------
+c   Initialisation de la dissipation :
+c   ----------------------------------
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+
+c-----------------------------------------------------------------------
+c   Initialisation de la physique :
+c   -------------------------------
+#ifdef CPP_PHYS
+      IF (call_iniphys.and.iflag_phys.eq.1) THEN
+         latfi(1)=rlatu(1)
+         lonfi(1)=0.
+         zcufi(1) = cu(1)
+         zcvfi(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)
+               zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i)
+               zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i)
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)
+         lonfi(ngridmx)= 0.
+         zcufi(ngridmx) = cu(ip1jm+1)
+         zcvfi(ngridmx) = cv(ip1jm-iim)
+         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+
+         WRITE(lunout,*)
+     .           'WARNING!!! vitesse verticale nulle dans la physique'
+
+         CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys ,
+     ,                latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp     )
+
+         call_iniphys=.false.
+
+      ENDIF
+#endif
+
+c  numero de stockage pour les fichiers de redemarrage:
+
+c-----------------------------------------------------------------------
+c   Initialisation des I/O :
+c   ------------------------
+
+
+      day_end = day_ini + nday
+      WRITE(lunout,300)day_ini,day_end
+
+#ifdef CPP_IOIPSL
+      CALL dynredem0_p("restart.nc", day_end, phis, nqmx)
+
+      ecripar = .TRUE.
+
+      if ( 1.eq.1) then
+      time_step = zdtvr
+      t_ops = iecri * daysec
+      t_wrt = iecri * daysec
+      CALL inithist_p(dynhist_file,day_ref,annee_ref,time_step,
+     .              t_ops, t_wrt, nqmx, histid, histvid)
+
+      t_ops = iperiod * time_step
+      t_wrt = periodav * daysec
+      CALL initdynav_p(dynhistave_file,day_ref,annee_ref,time_step,
+     .              t_ops, t_wrt, nqmx, histaveid)
+
+      dtav = iperiod*dtvr/daysec
+      endif
+
+
+#endif
+
+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/,/logic/)
+      CALL leapfrog_p(ucov,vcov,teta,ps,masse,phis,nq,q,clesphy0,
+     .              time_0)
+c$OMP END PARALLEL
+
+
+ 300  FORMAT('1'/,15x,'run du pas',i7,2x,'au pas',i7,2x,
+     . 'c''est a dire du jour',i7,3x,'au jour',i7//)
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/geopot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/geopot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/geopot.F	(revision 984)
@@ -0,0 +1,64 @@
+!
+! $Header$
+!
+      SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    ....   calcul du geopotentiel aux milieux des couches    .....
+c    *******************************************************************
+c
+c     ....   l'integration se fait de bas en haut  ....
+c
+c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+c              phi               est un  argum. de sortie pour le s-pg .
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER ngrid
+      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
+     *       phi(ngrid,llm)
+
+
+c   Local:
+c   ------
+
+      INTEGER  l, ij
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+
+      DO   1  ij  = 1, ngrid
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+   1  CONTINUE
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = 1,ngrid
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/geopot_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/geopot_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/geopot_p.F	(revision 984)
@@ -0,0 +1,66 @@
+      SUBROUTINE geopot_p ( ngrid, teta, pk, pks, phis, phi )
+      USE parallel
+      IMPLICIT NONE
+      
+      
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    ....   calcul du geopotentiel aux milieux des couches    .....
+c    *******************************************************************
+c
+c     ....   l'integration se fait de bas en haut  ....
+c
+c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+c              phi               est un  argum. de sortie pour le s-pg .
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+      INTEGER ngrid
+      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
+     *       phi(ngrid,llm)
+
+
+c   Local:
+c   ------
+      
+      INTEGER  l, ij,ijb,ije
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      IF (pole_sud)  ije=ij_end
+
+      DO  ij  = ijb, ije
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+      ENDDO
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = ijb,ije
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/getparam.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/getparam.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/getparam.F90	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+MODULE getparam
+   USE IOIPSL
+   INTERFACE getpar
+     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml
+   END INTERFACE
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    open(out_eff,file=fichier,status='unknown',form='formatted') 
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+    !
+    IMPLICIT NONE
+    !
+    close(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) comment
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_dyn_fi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_dyn_fi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_dyn_fi.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_dyn_fi_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_dyn_fi_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_dyn_fi_p.F	(revision 984)
@@ -0,0 +1,37 @@
+      SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi)
+      USE mod_interface_dyn_phys
+      USE dimphy
+      USE PARALLEL
+      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
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_ecrit_fi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_ecrit_fi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_ecrit_fi.F	(revision 984)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+	SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi)
+
+	IMPLICIT none
+
+c Transformer une variable de la grille d'ecriture a la grille physique
+	
+	INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield)
+c
+      INTEGER i, j, n, ig
+c
+c	print*,'iim jjm ',iim,jjm
+
+c modif par abd 21 02 01
+
+        jjm = jjmp1 - 1
+	do n = 1, nfield
+	    fi(1,n) = ecrit(1,1,n)
+            fi(nlon,n) = ecrit(1,jjm+1,n)
+         DO j = 2, jjm
+            ig = 2+(j-2)*iim
+            DO i = 1, iim
+	     fi(ig-1+i,n) = ecrit(i,j,n)
+            ENDDO
+         ENDDO
+      ENDDO
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_fi_dyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_fi_dyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_fi_dyn.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_fi_dyn_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_fi_dyn_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_fi_dyn_p.F	(revision 984)
@@ -0,0 +1,49 @@
+      SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn)
+      USE mod_interface_dyn_phys
+      USE dimphy
+      use parallel
+      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
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_int_dyn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_int_dyn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_int_dyn.F	(revision 984)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      subroutine gr_int_dyn(champin,champdyn,iim,jp1)
+      implicit none
+c=======================================================================
+c   passage d'un champ interpole a un champ sur grille scalaire
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER iim
+      integer ip1, jp1
+      REAL champin(iim, jp1)
+      REAL champdyn(iim+1, jp1)
+
+      INTEGER i, j
+      real polenord, polesud
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      ip1 = iim + 1
+      polenord = 0.
+      polesud = 0.
+      do i = 1, iim
+        polenord = polenord + champin (i, 1)
+        polesud = polesud + champin (i, jp1)
+      enddo
+      polenord = polenord / iim
+      polesud = polesud / iim
+      do j = 1, jp1
+        do i = 1, iim
+          if (j .eq. 1) then
+            champdyn(i, j) = polenord
+          else if (j .eq. jp1) then
+            champdyn(i, j) = polesud
+          else
+            champdyn(i, j) = champin (i, j)
+          endif
+        enddo
+        champdyn(ip1, j) = champdyn(1, j)
+      enddo
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_u_scal.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_u_scal.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_u_scal.F	(revision 984)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_u_scal(nx,x_u,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=ip1jmp1,2,-1
+            x_scal(ij,l)=
+     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
+     s      /(aireu(ij)+aireu(ij-1))
+         ENDDO
+      ENDDO
+
+      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_u_scal_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_u_scal_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_u_scal_p.F	(revision 984)
@@ -0,0 +1,73 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_u_scal_p(nx,x_u,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      USE parallel
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+      INTEGER :: ijb,ije
+
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+1
+      
+      DO l=1,nx
+         DO ij=ijb,ije
+            x_scal(ij,l)=
+     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
+     s      /(aireu(ij)+aireu(ij-1))
+         ENDDO
+      ENDDO
+
+cym      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+      ijb=ij_begin
+      ije=ij_end
+
+      DO l=1,nx
+         DO ij=ijb,ije-iip1+1,iip1
+	   x_scal(ij,l)=x_scal(ij+iip1-1,l)
+	 ENDDO
+      ENDDO
+      RETURN
+      
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_v_scal_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_v_scal_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gr_v_scal_p.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_v_scal_p(nx,x_v,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      USE parallel
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+      INTEGER :: ijb,ije
+c-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+1
+      if (pole_sud)  ije=ij_end-1
+      
+      DO l=1,nx
+         DO ij=ijb,ije
+            x_scal(ij,l)=
+     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
+     s      /(airev(ij-iip1)+airev(ij))
+         ENDDO
+      ENDDO
+      
+      if (pole_nord) then
+        DO l=1,nx
+           DO ij=1,iip1
+              x_scal(ij,l)=0.
+           ENDDO
+        ENDDO
+      endif
+    
+      if (pole_sud) then
+        DO l=1,nx
+           DO ij=ip1jm+1,ip1jmp1
+              x_scal(ij,l)=0.
+           ENDDO
+        ENDDO
+      endif
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/grad.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/grad.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/grad.F	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+      SUBROUTINE  grad(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      INTEGER klevel
+      REAL  pg( ip1jmp1,klevel )
+      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+      INTEGER  l,ij
+c
+c
+      DO 6 l = 1,klevel
+c
+      DO 2  ij = 1, ip1jmp1 - 1
+      pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = iip1, ip1jmp1, iip1
+      pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      DO 4 ij = 1,ip1jm
+      pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/grad_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/grad_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/grad_p.F	(revision 984)
@@ -0,0 +1,53 @@
+      SUBROUTINE  grad_p(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      INTEGER klevel
+      REAL  pg( ip1jmp1,klevel )
+      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+      INTEGER  l,ij
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 6 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      DO 2  ij = ijb, ije - 1
+        pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = ijb+iip1-1, ije, iip1
+        pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4 ij = ijb,ije
+        pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv.F	(revision 984)
@@ -0,0 +1,57 @@
+!
+! $Header$
+!
+      SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c    Auteur :   P. Le Van
+c
+c   ***************************************************************
+c
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   ****************************************************************
+c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
+
+      REAL div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+c
+c
+      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+c
+      DO 10 iter = 1,ld
+c
+      CALL  diverg( klevel,  gdx , gdy, div          )
+      CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 )
+      CALL    grad( klevel,  div, gdx, gdy           )
+c
+      DO 5  l = 1, klevel
+      DO 3 ij = 1, ip1jmp1
+      gdx( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+      DO 4 ij = 1, ip1jm
+      gdy( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv2.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c     P. Le Van
+c
+c   **********************************************************
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   **********************************************************
+c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+c
+c     ........    variables en arguments      ........
+
+      INTEGER klevel
+      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL   gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL div(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      
+c    ........................................................
+c
+c
+      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+
+
+      CALL    divergf( klevel, gdx,   gdy , div )
+
+      IF( ld.GT.1 )   THEN
+
+        CALL laplacien ( klevel, div,  div     )
+
+c    ......  Iteration de l'operateur laplacien_gam   .......
+
+        DO iter = 1, ld -2
+         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
+     *                       unsapolnga1, unsapolsga1,  div, div       )
+        ENDDO
+
+      ENDIF
+
+
+       CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
+       CALL  grad  ( klevel,  div,   gdx,  gdy             )
+
+c
+       DO   l = 1, klevel
+         DO  ij = 1, ip1jmp1
+          gdx( ij,l ) = gdx( ij,l ) * nugrads
+         ENDDO
+         DO  ij = 1, ip1jm
+          gdy( ij,l ) = gdy( ij,l ) * nugrads
+         ENDDO
+       ENDDO
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv2_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv2_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv2_p.F	(revision 984)
@@ -0,0 +1,144 @@
+      SUBROUTINE gradiv2_p(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+c
+c     P. Le Van
+c
+c   **********************************************************
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   **********************************************************
+c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
+      USE parallel
+      USE times
+      USE Write_field_p
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+c
+c     ........    variables en arguments      ........
+
+      INTEGER klevel
+      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE ::  gdx( ip1jmp1,llm ),  gdy( ip1jm,llm )
+      REAL   gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL,SAVE :: div(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      INTEGER :: ijb,ije,jjb,jje
+      
+c    ........................................................
+c
+c
+c      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+c      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO   l = 1, klevel
+        gdx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT      
+      
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO   l = 1, klevel
+        gdy(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(gdy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+
+
+      CALL    divergf_p( klevel, gdx,   gdy , div )
+c      call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/)))
+
+      IF( ld.GT.1 )   THEN
+c$OMP BARRIER
+c$OMP MASTER        
+	call suspend_timer(timer_dissip)
+        call exchange_Hallo(div,ip1jmp1,llm,1,1)
+        call resume_timer(timer_dissip)
+c$OMP END MASTER        
+c$OMP BARRIER
+	CALL laplacien_p ( klevel, div,  div     )
+
+c    ......  Iteration de l'operateur laplacien_gam   .......
+c         call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/)))
+
+        DO iter = 1, ld -2
+c$OMP BARRIER
+c$OMP MASTER
+	 call suspend_timer(timer_dissip)
+         call exchange_Hallo(div,ip1jmp1,llm,1,1)
+	 call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
+     *                       unsapolnga1, unsapolsga1,  div, div       )
+        ENDDO
+c        call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/)))
+      ENDIF
+
+       jjb=jj_begin
+       jje=jj_end
+       
+       CALL filtreg_p( div   ,jjb,jje, jjp1, klevel, 2, 1, .TRUE., 1 )
+c       call exchange_Hallo(div,ip1jmp1,llm,0,1)
+c$OMP BARRIER
+c$OMP MASTER        
+	call suspend_timer(timer_dissip)
+	call exchange_Hallo(div,ip1jmp1,llm,1,1)
+        call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+c       call write_field3d_p('div4',reshape(div,(/iip1,jjp1,llm/)))
+       CALL  grad_p  ( klevel,  div,   gdx,  gdy             )
+
+c
+      ijb=ij_begin
+      ije=ij_end
+         
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+       DO   l = 1, klevel
+         
+         if (pole_sud) ije=ij_end
+         DO  ij = ijb, ije
+          gdx_out( ij,l ) = gdx( ij,l ) * nugrads
+         ENDDO
+         
+         if (pole_sud) ije=ij_end-iip1
+         DO  ij = ijb, ije
+          gdy_out( ij,l ) = gdy( ij,l ) * nugrads
+         ENDDO
+       
+       ENDDO
+c$OMP END DO NOWAIT
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradiv_p.F	(revision 984)
@@ -0,0 +1,109 @@
+      SUBROUTINE gradiv_p(klevel, xcov, ycov, ld, gdx_out, gdy_out )
+c
+c    Auteur :   P. Le Van
+c
+c   ***************************************************************
+c
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   ****************************************************************
+c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+c
+c     
+      USE parallel
+      USE times
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE :: gdx( ip1jmp1,llm ),   gdy( ip1jm,llm )
+
+      REAL gdx_out( ip1jmp1,klevel ),   gdy_out( ip1jm,klevel )
+
+      REAL,SAVE ::  div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+c      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+      
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1,klevel
+        gdx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1,klevel
+        gdy(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+      DO 10 iter = 1,ld
+
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(gdy,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER      
+c$OMP BARRIER
+
+      CALL  diverg_p( klevel,  gdx , gdy, div          )
+      
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2,1, .true.,2 )
+      
+c      call exchange_Hallo(div,ip1jmp1,llm,0,1)
+
+c$OMP BARRIER
+c$OMP MASTER       
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(div,ip1jmp1,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL    grad_p( klevel,  div, gdx, gdy           )
+c
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 5  l = 1, klevel
+      
+      if(pole_sud) ije=ij_end
+      DO 3 ij = ijb, ije
+        gdx_out( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+   
+      if(pole_sud) ije=ij_end-iip1
+      DO 4 ij = ijb, ije
+        gdy_out( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradsdef.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradsdef.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/gradsdef.h	(revision 984)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+      integer nfmx,imx,jmx,lmx,nvarmx
+      parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000)
+
+      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
+
+      integer imd(imx),jmd(jmx),lmd(lmx)
+      integer iid(imx),jid(jmx)
+      integer ifd(imx),jfd(jmx)
+      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
+
+      integer nvar(nfmx),ivar(nfmx)
+      logical firsttime(nfmx)
+
+      character*10 var(nvarmx,nfmx),fichier(nfmx)
+      character*40 title(nfmx),tvar(nvarmx,nfmx)
+
+      common/gradsdef/xd,yd,zd,dtime,
+     s   imd,jmd,lmd,iid,jid,ifd,jfd,
+     s   unit,irec,nvar,ivar,itime,nld,firsttime,
+     s   var,fichier,title,tvar
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/grid_atob.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/grid_atob.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/grid_atob.F	(revision 984)
@@ -0,0 +1,971 @@
+!
+! $Header$
+!
+      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Aucune ponderation est consideree (voir grille_p)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+      REAL distans(2200*1100)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+c Calculer les limites des zones des nouveaux points
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c Determiner la zone sur laquelle chaque ancien point se trouve
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               number(ii,jj) = number(ii,jj) + 1.0
+               sortie(ii,jj) = sortie(ii,jj) + entree(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c Si aucun ancien point tombe sur une zone, c'est un probleme
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+      SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Consideration de la distance des points (voir grille_m)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(200),d(200)
+      REAL number(400,200)
+      INTEGER indx(400,200), indy(400,200)
+      REAL dist(400,200), distsom(400,200)
+c
+      IF (imar.GT.400 .OR. jmar.GT.200) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+      IF (imdep.GT.400 .OR. jmdep.GT.200) THEN
+         PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep
+         CALL ABORT
+      ENDIF
+c
+c calculer les bords a et b de la nouvelle grille
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+c
+c calculer les bords c et d de la nouvelle grille
+c
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+c
+c trouver les indices (indx,indy) de la nouvelle grille sur laquelle
+c un point de l'ancienne grille est tombe.
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               indx(i,j) = ii
+               indy(i,j) = jj
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c faire une verification
+c
+
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN
+            PRINT*, 'Probleme grave,i,j,indx,indy=',
+     .              i,j,indx(i,j),indy(i,j)
+            CALL abort
+         ENDIF
+      ENDDO
+      ENDDO
+
+c
+c calculer la distance des anciens points avec le nouveau point,
+c on prend ensuite une sorte d'inverse pour ponderation.
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         distsom(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2
+     .                     +(ydata(j)-y(indy(i,j)))**2 )
+         distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j))
+     .                                  + dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1.
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j))
+      ENDDO
+      ENDDO
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j))
+     .                                 + entree(i,j) * dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j))
+     .                                 + dist(i,j)
+      ENDDO
+      ENDDO
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+      SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief,
+     .                    imar, jmar, x, y, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique
+c                           un champ indicateur (masque) terre/ocean
+c                           terre:1; ocean:0
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL relief(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL num_tot(2200,1100), num_oce(2200,1100)
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_oce(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+               IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) )
+     .             num_oce(ii,jj) = num_oce(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+c
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN
+              mask(i,j) = 0.
+           ELSE
+              mask(i,j) = 1.
+           ENDIF
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c
+c
+
+
+      SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une
+c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur
+c fixe (0.001m).
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar), mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_tot(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              sortie(ii,jj)  = sortie(ii,jj) + LOG(entree(i,j))
+              num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+       IF (NINT(mask(i,j)).EQ.1) THEN
+         IF (num_tot(i,j) .GT. 0.0) THEN
+            sortie(i,j) = sortie(i,j) / num_tot(i,j)
+            sortie(i,j) = EXP(sortie(i,j))
+         ELSE
+            PRINT*, 'probleme,i,j=', i,j
+ccc            CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+       ELSE
+         sortie(i,j) = 0.001
+       ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+
+      SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01,
+     .                    imar, jmar, x, y, frac_ice)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la
+c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace
+c (entre 0 et 1) dans une grille plus grossiere.
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL glace01(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL frac_ice(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400), num_ice(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_ice(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+             num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+              IF (NINT(glace01(i,j)).EQ.1 ) 
+     .       num_ice(ii,jj) = num_ice(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF (num_ice(i,j).GT.0.001) THEN
+            frac_ice(i,j) = num_ice(i,j) / num_tot(i,j)
+           ELSE
+              frac_ice(i,j) = 0.0
+           ENDIF
+         ELSE
+           PRINT*, 'probleme,i,j=', i,j
+ccc           CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN
+            frac_ice(i,j) = 1.0
+         ELSE
+            frac_ice(i,j) = 0.0
+         ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+      SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief,
+     .                    immod, jmmod, xmod, ymod, rugs)
+c=======================================================================
+c Calculer la longueur de rugosite liee au relief en utilisant
+c l'ecart-type dans une maille de 1x1
+C=======================================================================
+      IMPLICIT none
+c
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      REAL amin, AMAX
+c
+      INTEGER imrel, jmrel
+      REAL xrel(imrel),yrel(jmrel)
+      REAL relief(imrel,jmrel)
+c
+      INTEGER immod, jmmod
+      REAL xmod(immod),ymod(jmmod)
+      REAL rugs(immod,jmmod)
+c
+      INTEGER imtmp, jmtmp
+      PARAMETER (imtmp=360,jmtmp=180)
+      REAL xtmp(imtmp), ytmp(jmtmp)
+      REAL*8 cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp)
+      REAL zzzz
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+c
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+c
+      IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN
+         PRINT*, 'immod ou jmmod trop grand', immod, jmmod
+         CALL ABORT
+      ENDIF
+c
+c Calculs intermediares:
+c
+      xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0
+      DO i = 2, imtmp
+         xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp)
+      ENDDO
+      DO i = 1, imtmp
+         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+      ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0
+      DO j = 2, jmtmp
+         ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp)
+      ENDDO
+      DO j = 1, jmtmp
+         ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+c
+      a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0
+      b(1) = (xtmp(1)+xtmp(2))/2.0
+      DO i = 2, imtmp-1
+         a(i) = b(i-1)
+         b(i) = (xtmp(i)+xtmp(i+1))/2.0
+      ENDDO
+      a(imtmp) = b(imtmp-1)
+      b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0
+
+      c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0
+      d(1) = (ytmp(1)+ytmp(2))/2.0
+      DO j = 2, jmtmp-1
+         c(j) = d(j-1)
+         d(j) = (ytmp(j)+ytmp(j+1))/2.0
+      ENDDO
+      c(jmtmp) = d(jmtmp-1)
+      d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0
+
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         number(i,j) = 0.0
+         cham1tmp(i,j) = 0.0
+         cham2tmp(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imtmp
+      DO jj = 1, jmtmp
+        DO i = 1, imrel
+         IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmrel
+          IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j)
+              cham2tmp(ii,jj) = cham2tmp(ii,jj) 
+     .                              + relief(i,j)*relief(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         IF (number(i,j) .GT. 0.001) THEN
+         cham1tmp(i,j) = cham1tmp(i,j) / number(i,j)
+         cham2tmp(i,j) = cham2tmp(i,j) / number(i,j)
+         zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2
+         if (zzzz .lt. 0.0) then
+           if (zzzz .gt. -7.5) then
+             zzzz = 0.0
+             print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0'
+           else
+              stop 'Pb rugsoro, zzzz <-7.5'
+           endif
+         endif
+         cham2tmp(i,j) = SQRT(zzzz)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = cham2tmp(1,1)
+      AMAX = cham2tmp(1,1)
+      DO j = 1, jmtmp
+      DO i = 1, imtmp
+         IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j)
+         IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type 1x1:', amin, AMAX
+c
+c
+c
+      a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0
+      b(1) = (xmod(1)+xmod(2))/2.0
+      DO i = 2, immod-1
+         a(i) = b(i-1)
+         b(i) = (xmod(i)+xmod(i+1))/2.0
+      ENDDO
+      a(immod) = b(immod-1)
+      b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0
+
+      c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0
+      d(1) = (ymod(1)+ymod(2))/2.0
+      DO j = 2, jmmod-1
+         c(j) = d(j-1)
+         d(j) = (ymod(j)+ymod(j+1))/2.0
+      ENDDO
+      c(jmmod) = d(jmmod-1)
+      d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         number(i,j) = 0.0
+         rugs(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, immod
+      DO jj = 1, jmmod
+        DO i = 1, imtmp
+         IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmtmp
+          IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              rugs(ii,jj) = rugs(ii,jj)
+     .                       + LOG(MAX(0.001,cham2tmp(i,j)))
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         IF (number(i,j) .GT. 0.001) THEN
+         rugs(i,j) = rugs(i,j) / number(i,j)
+         rugs(i,j) = EXP(rugs(i,j))
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imtmp*jmtmp,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imtmp*jmtmp
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imtmp + 1
+         i_proche = ij_proche - (j_proche-1)*imtmp
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         rugs(i,j) = LOG(MAX(0.001,cham2tmp(i_proche,j_proche)))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type du modele:', amin, AMAX
+c
+      DO j = 1, jmmod
+      DO i = 1, immod
+         rugs(i,j) = rugs(i,j) / AMAX * 20.0
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Longueur de rugosite du modele:', amin, AMAX
+c
+      RETURN
+      END
+c
+      SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance)
+c
+c Auteur: Laurent Li (le 30 decembre 1996)
+c
+c Ce programme calcule la distance minimale (selon le grand cercle)
+c entre deux points sur la terre
+c
+c Input:
+      INTEGER im, jm ! dimensions
+      REAL rf_lon ! longitude du point de reference (degres)
+      REAL rf_lat ! latitude du point de reference (degres)
+      REAL rlon(im), rlat(jm) ! longitude et latitude des points
+c
+c Output:
+      REAL distance(im,jm) ! distances en metre
+c
+      REAL rlon1, rlat1
+      REAL rlon2, rlat2
+      REAL dist
+      REAL pa, pb, p, pi
+c
+      REAL radius
+      PARAMETER (radius=6371229.)
+c
+      pi = 4.0 * ATAN(1.0)
+c
+      DO 9999 j = 1, jm
+      DO 9999 i = 1, im
+c
+      rlon1=rf_lon
+      rlat1=rf_lat
+      rlon2=rlon(i)
+      rlat2=rlat(j)
+      pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a
+      pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b
+      p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens)
+c
+      dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p))
+      dist = radius * dist
+      distance(i,j) = dist
+c
+ 9999 CONTINUE
+c
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/grid_noro.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/grid_noro.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/grid_noro.F	(revision 984)
@@ -0,0 +1,524 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata,
+     .             imar, jmar, x, y,
+     .             zphi,zmea,zstd,zsig,zgam,zthe,
+     .             zpic,zval,mask)
+c=======================================================================
+c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead)
+c
+c      Compute the Parameters of the SSO scheme as described in
+c      LOTT & MILLER (1997) and LOTT(1999).
+c      Target points are on a rectangular grid:
+c      iim+1 latitudes including North and South Poles;
+c      jjm+1 longitudes, with periodicity jjm+1=1.
+c      aux poles.  At the poles the fields value is repeated
+c      jjm+1 time.
+c      The parameters a,b,c,d represent the limite of the target
+c      gridpoint region. The means over this region are calculated
+c      from USN data, ponderated by a weight proportional to the 
+c      surface occupated by the data inside the model gridpoint area.
+c      In most circumstances, this weight is the ratio between the
+c      surface of the USN gridpoint area and the surface of the
+c      model gridpoint area. 
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X and Y input field
+c        xdata, ydata: coordinates X and Y input field
+c        zdata: Input field
+c        In this version it is assumed that the entry data come from
+c        the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080.
+c OUTPUT:
+c        imar, jmar: dimensions X and Y Output field
+c        x, y: ccordinates  X and Y Output field.
+c             zmea:  Mean orographie   
+c             zstd:  Standard deviation
+c             zsig:  Slope
+c             zgam:  Anisotropy
+c             zthe:  Orientation of the small axis
+c             zpic:  Maximum altitude
+c             zval:  Minimum altitude
+C=======================================================================
+
+      IMPLICIT INTEGER (I,J)
+      IMPLICIT REAL(X,Z) 
+      
+	  parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5)
+#include "dimensions.h"
+	  REAL xusn(iusn+2*iext),yusn(jusn+2)	
+      REAL zusn(iusn+2*iext,jusn+2)
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL zdata(imdep,jmdep)
+c
+      INTEGER imar, jmar
+  
+C INTERMEDIATE FIELDS  (CORRELATIONS OF OROGRAPHY GRADIENT)
+
+      REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1)
+      REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1)
+      REAL weight(iim+1,jjm+1)
+
+C CORRELATIONS OF USN OROGRAPHY GRADIENTS
+
+      REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2)
+      REAL zxtzyusn(iusn+2*iext,jusn+2)
+      REAL x(imar+1),y(jmar),zphi(imar+1,jmar)
+      REAL zmea(imar+1,jmar),zstd(imar+1,jmar)
+      REAL zmea0(imar+1,jmar) ! GK211005 (CG)
+      REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar)
+      REAL zpic(imar+1,jmar),zval(imar+1,jmar)
+cxxx PB     integer mask(imar+1,jmar)
+      real mask(imar+1,jmar), mask_tmp(imar+1,jmar)
+      real num_tot(2200,1100),num_lan(2200,1100)
+c
+      REAL a(2200),b(2200),c(1100),d(1100)
+      logical masque_lu
+c
+      print *,' parametres de l orographie a l echelle sous maille' 
+      xpi=acos(-1.)
+      rad    = 6 371 229.
+      zdeltay=2.*xpi/float(jusn)*rad
+c
+c utilise-t'on un masque lu?
+c
+      masque_lu = .true.
+      if (maxval(mask) == -99999 .and. minval(mask) == -99999) then
+        masque_lu= .false.
+        masque = 0.0
+      endif
+      write(*,*)'Masque lu', masque_lu
+c
+c  quelques tests de dimensions:
+c    
+c
+      if(iim.ne.imar) STOP 'Problem dim. x'
+      if(jjm.ne.jmar-1) STOP 'Problem dim. y'
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar or jmar too big', imar, jmar
+         CALL ABORT
+      ENDIF
+
+      IF(imdep.ne.iusn.or.jmdep.ne.jusn)then
+         print *,' imdep or jmdep bad dimensions:',imdep,jmdep
+         call abort
+      ENDIF
+
+      IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN
+        print *,' imar or jmar bad dimensions:',imar,jmar
+        call abort
+      ENDIF
+
+
+c      print *,'xdata:',xdata
+c      print *,'ydata:',ydata
+c      print *,'x:',x
+c      print *,'y:',y
+c
+C  EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT
+C  BOUNDARIES:
+c
+      DO j=1,jusn
+        yusn(j+1)=ydata(j)
+      DO i=1,iusn
+        zusn(i+iext,j+1)=zdata(i,j)
+        xusn(i+iext)=xdata(i)
+      ENDDO
+      DO i=1,iext
+        zusn(i,j+1)=zdata(iusn-iext+i,j)
+        xusn(i)=xdata(iusn-iext+i)-2.*xpi
+        zusn(iusn+iext+i,j+1)=zdata(i,j)
+        xusn(iusn+iext+i)=xdata(i)+2.*xpi
+      ENDDO
+      ENDDO
+
+        yusn(1)=ydata(1)+(ydata(1)-ydata(2))
+        yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1))
+       DO i=1,iusn/2+iext
+        zusn(i,1)=zusn(i+iusn/2,2)
+        zusn(i+iusn/2+iext,1)=zusn(i,2)
+        zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1)
+        zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1)
+       ENDDO
+c  
+c COMPUTE LIMITS OF MODEL GRIDPOINT AREA
+C     ( REGULAR GRID)
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar+1) = b(imar)
+      b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+c
+c  initialisations:
+c
+      DO i = 1, imar+1
+      DO j = 1, jmar
+         weight(i,j) = 0.0
+         zxtzx(i,j)  = 0.0
+         zytzy(i,j)  = 0.0
+         zxtzy(i,j)  = 0.0
+         ztz(i,j)    = 0.0
+         zmea(i,j)   = 0.0
+         zpic(i,j)  =-1.E+10
+         zval(i,j)  = 1.E+10
+      ENDDO
+      ENDDO
+c
+c  COMPUTE SLOPES CORRELATIONS ON USN GRID
+c
+         DO j = 1,jusn+2 
+         DO i = 1, iusn+2*iext
+            zytzyusn(i,j)=0.0
+            zxtzxusn(i,j)=0.0
+            zxtzyusn(i,j)=0.0
+         ENDDO
+         ENDDO
+
+
+         DO j = 2,jusn+1 
+            zdeltax=zdeltay*cos(yusn(j))
+         DO i = 2, iusn+2*iext-1
+            zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2
+            zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2
+            zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay
+     *                   *(zusn(i+1,j)-zusn(i-1,j))/zdeltax
+         ENDDO
+         ENDDO
+c
+c  SUMMATION OVER GRIDPOINT AREA
+c 
+      zleny=xpi/float(jusn)*rad
+      xincr=xpi/2./float(jusn)
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+       num_tot(ii,jj)=0.
+       num_lan(ii,jj)=0.
+c        PRINT *,' iteration ii jj:',ii,jj
+         DO j = 2,jusn+1 
+c         DO j = 3,jusn 
+            zlenx=zleny*cos(yusn(j))
+            zdeltax=zdeltay*cos(yusn(j))
+            zbordnor=(c(jj)-yusn(j)+xincr)*rad
+            zbordsud=(yusn(j)-d(jj)+xincr)*rad
+            weighy=AMAX1(0.,
+     *             amin1(zbordnor,zbordsud,zleny))
+         IF(weighy.ne.0)THEN
+         DO i = 2, iusn+2*iext-1
+            zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j))
+            zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j))
+            weighx=AMAX1(0.,
+     *             amin1(zbordest,zbordoue,zlenx))
+            IF(weighx.ne.0)THEN
+            num_tot(ii,jj)=num_tot(ii,jj)+1.0
+            if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
+            weight(ii,jj)=weight(ii,jj)+weighx*weighy
+            zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy
+            zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy
+            zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy
+            ztz(ii,jj)  =ztz(ii,jj)  +zusn(i,j)*zusn(i,j)*weighx*weighy
+c mean
+            zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy
+c peacks
+            zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j))
+c valleys
+            zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j))
+            ENDIF
+         ENDDO
+         ENDIF
+         ENDDO
+       ENDDO
+       ENDDO
+c
+c  COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND
+C  LOTT (1999) SSO SCHEME.
+c
+      zllmmea=0.
+      zllmstd=0.
+      zllmsig=0.
+      zllmgam=0.
+      zllmpic=0.
+      zllmval=0.
+      zllmthe=0.
+      zminthe=0.
+c     print 100,' '
+c100  format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') 
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Mask
+cXXX           if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then
+cXXX             mask(ii,jj)=1
+cXXX           else
+cXXX             mask(ii,jj)=0
+cXXX           ENDIF
+             if (.not. masque_lu) then
+               mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj)
+             endif
+c  Mean Orography:
+           zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj)
+           zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj)
+           zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj)
+           zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj)
+           ztz(ii,jj)  =ztz(ii,jj)/weight(ii,jj)
+c  Standard deviation:
+           zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2))
+         ELSE
+            PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+       ENDDO
+       ENDDO
+
+C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES:
+
+       DO ii = 1, imar+1
+         zxtzx(ii,1)=zxtzx(ii,2)
+         zxtzx(ii,jmar)=zxtzx(ii,jmar-1)
+         zxtzy(ii,1)=zxtzy(ii,2)
+         zxtzy(ii,jmar)=zxtzy(ii,jmar-1)
+         zytzy(ii,1)=zytzy(ii,2)
+         zytzy(ii,jmar)=zytzy(ii,jmar-1)
+       ENDDO
+
+C  FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME.
+
+C  FIRST FILTER, MOVING AVERAGE OVER 9 POINTS.
+
+       zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee
+       CALL MVA9(zmea,iim+1,jjm+1)
+       CALL MVA9(zstd,iim+1,jjm+1)
+       CALL MVA9(zpic,iim+1,jjm+1)
+       CALL MVA9(zval,iim+1,jjm+1)
+       CALL MVA9(zxtzx,iim+1,jjm+1)
+       CALL MVA9(zxtzy,iim+1,jjm+1) 
+       CALL MVA9(zytzy,iim+1,jjm+1)
+CXXX   Masque prenant en compte maximum de terre
+CXXX  On seuil a 10% de terre de terre car en dessous les parametres de surface n'on
+CXXX pas de sens (PB)
+       mask_tmp= 0.0
+       WHERE(mask .GE. 0.1) mask_tmp = 1.
+
+       DO ii = 1, imar
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Coefficients K, L et M:
+           xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2.
+           xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2.
+           xm=zxtzy(ii,jj)
+           xp=xk-sqrt(xl**2+xm**2)
+           xq=xk+sqrt(xl**2+xm**2)
+           xw=1.e-8
+           if(xp.le.xw) xp=0.
+           if(xq.le.xw) xq=xw
+           if(abs(xm).le.xw) xm=xw*sign(1.,xm)
+c slope: 
+cXXX           zsig(ii,jj)=sqrt(xq)*mask(ii,jj)
+cXXXc isotropy:
+cXXX           zgam(ii,jj)=xp/xq*mask(ii,jj)
+cXXXc angle theta:
+cXXX           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj)
+cXXX           zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+cXXX           zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+cXXX           zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj)
+cXXX           zval(ii,jj)=zval(ii,jj)*mask(ii,jj)
+cXXX           zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj)
+CXX* PB modif pour maque de terre fractionnaire
+c slope: 
+           zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj)
+c isotropy:
+           zgam(ii,jj)=xp/xq*mask_tmp(ii,jj)
+c angle theta:
+           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj)
+           ! GK211005 (CG) ne pas forcement lisser la topo
+           ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj)
+           !
+           zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj)
+           zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj)
+           zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj)
+c          print 101,ii,jj,
+c    *           zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj),
+c    *           zthe(ii,jj)
+c101  format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1)     
+         ELSE
+c           PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+      zllmmea=AMAX1(zmea(ii,jj),zllmmea)
+      zllmstd=AMAX1(zstd(ii,jj),zllmstd)
+      zllmsig=AMAX1(zsig(ii,jj),zllmsig)
+      zllmgam=AMAX1(zgam(ii,jj),zllmgam)
+      zllmthe=AMAX1(zthe(ii,jj),zllmthe)
+      zminthe=amin1(zthe(ii,jj),zminthe)
+      zllmpic=AMAX1(zpic(ii,jj),zllmpic)
+      zllmval=AMAX1(zval(ii,jj),zllmval)
+       ENDDO
+       ENDDO
+      print *,'  MEAN ORO:',zllmmea
+      print *,'  ST. DEV.:',zllmstd
+      print *,'  PENTE:',zllmsig
+      print *,' ANISOTROP:',zllmgam
+      print *,'  ANGLE:',zminthe,zllmthe	
+      print *,'  pic:',zllmpic
+      print *,'  val:',zllmval
+      
+C
+c gamma and theta a 1. and 0. at poles
+c
+      DO jj=1,jmar
+      zmea(imar+1,jj)=zmea(1,jj)
+      zphi(imar+1,jj)=zphi(1,jj)
+      zpic(imar+1,jj)=zpic(1,jj)
+      zval(imar+1,jj)=zval(1,jj)
+      zstd(imar+1,jj)=zstd(1,jj)
+      zsig(imar+1,jj)=zsig(1,jj)
+      zgam(imar+1,jj)=zgam(1,jj)
+      zthe(imar+1,jj)=zthe(1,jj)
+      ENDDO
+
+
+      zmeanor=0.0
+      zmeasud=0.0
+      zstdnor=0.0
+      zstdsud=0.0
+      zsignor=0.0
+      zsigsud=0.0
+      zweinor=0.0
+      zweisud=0.0
+      zpicnor=0.0
+      zpicsud=0.0                                   
+      zvalnor=0.0
+      zvalsud=0.0 
+
+      DO ii=1,imar
+      zweinor=zweinor+              weight(ii,   1)
+      zweisud=zweisud+              weight(ii,jmar)
+      zmeanor=zmeanor+zmea(ii,   1)*weight(ii,   1)
+      zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar)
+      zstdnor=zstdnor+zstd(ii,   1)*weight(ii,   1)
+      zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar)
+      zsignor=zsignor+zsig(ii,   1)*weight(ii,   1)
+      zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar)
+      zpicnor=zpicnor+zpic(ii,   1)*weight(ii,   1)
+      zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar)
+      zvalnor=zvalnor+zval(ii,   1)*weight(ii,   1)
+      zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar)
+      ENDDO
+
+      DO ii=1,imar+1
+      zmea(ii,   1)=zmeanor/zweinor
+      zmea(ii,jmar)=zmeasud/zweisud
+      zphi(ii,   1)=zmeanor/zweinor
+      zphi(ii,jmar)=zmeasud/zweisud
+      zpic(ii,   1)=zpicnor/zweinor
+      zpic(ii,jmar)=zpicsud/zweisud
+      zval(ii,   1)=zvalnor/zweinor
+      zval(ii,jmar)=zvalsud/zweisud
+      zstd(ii,   1)=zstdnor/zweinor
+      zstd(ii,jmar)=zstdsud/zweisud
+      zsig(ii,   1)=zsignor/zweinor
+      zsig(ii,jmar)=zsigsud/zweisud
+      zgam(ii,   1)=1.
+      zgam(ii,jmar)=1.
+      zthe(ii,   1)=0.
+      zthe(ii,jmar)=0.
+      ENDDO
+
+      RETURN
+      END
+
+      SUBROUTINE MVA9(X,IMAR,JMAR)
+
+C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
+
+      PARAMETER (ISMo=300,JSMo=200)
+      REAL X(IMAR,JMAR),XF(ISMo,JSMo)
+      real WEIGHTpb(-1:1,-1:1)
+
+      if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)'
+      if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)'
+      
+      SUM=0.
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
+          SUM=SUM+WEIGHTpb(IS,JS)
+        ENDDO
+      ENDDO
+      
+c     WRITE(*,*) 'MVA9 ', IMAR, JMAR
+c     WRITE(*,*) 'MVA9 ', WEIGHTpb
+c     WRITE(*,*) 'MVA9 SUM ', SUM
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        DO I=2,IMAR-1
+          XF(I,J)=0.
+          DO IS=-1,1
+            DO JS=-1,1
+              XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS)
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        XF(1,J)=0.
+        IS=IMAR-1
+        DO JS=-1,1 
+          XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS)
+        ENDDO
+        DO IS=0,1 
+          DO JS=-1,1 
+            XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS)
+          ENDDO
+        ENDDO
+        XF(IMAR,J)=XF(1,J)
+      ENDDO
+
+      DO I=1,IMAR
+        XF(I,1)=XF(I,2)
+        XF(I,JMAR)=XF(I,JMAR-1)
+      ENDDO
+
+      DO I=1,IMAR
+        DO J=1,JMAR
+          X(I,J)=XF(I,J)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/grilles_gcm_netcdf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/grilles_gcm_netcdf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/grilles_gcm_netcdf.F	(revision 984)
@@ -0,0 +1,305 @@
+!
+! $Header$
+!
+c
+c
+
+      PROGRAM create_fausse_var
+C
+      IMPLICIT NONE
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+
+      real temp(iim+1,jjm+1)
+#include "netcdf.inc"
+
+c Attributs netcdf sortie
+        character*64 fich_out
+        integer*4 ncid_out,rcode_out
+        integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid
+        integer*4 out_varid
+        integer*4 out_lonudim,out_lonvdim
+        integer*4 out_latudim,out_latvdim,out_dim(3)
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      integer start(4),count(4)
+
+	integer status,i,j
+        real rlatudeg(jjp1),rlatvdeg(jjm)
+        real rlonudeg(iip1),rlonvdeg(iip1)
+
+      real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
+      real acoslat,dxkm,dykm,resol(iip1,jjp1)
+
+#include "serre.h"
+#include "fxyprim.h"
+
+      print*,'OK0'
+
+      rad = 6400000
+      omeg = 7.272205e-05
+      g = 9.8
+      kappa = 0.285716
+      daysec = 86400
+      cpp = 1004.70885
+
+      preff = 101325.
+      pa= 50000.
+
+c     open(99,file='run.def',status='old',form='formatted')
+c     CALL defrun_new( 99, .TRUE.,clesphy0 )
+c     close(99)
+
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+      CALL iniconst
+      CALL inigeom
+
+
+      print*,'OK1'
+      do j=1,jjp1
+         rlatudeg(j)=rlatu(j)*180./pi
+      enddo
+      do j=1,jjm
+         rlatvdeg(j)=rlatv(j)*180./pi
+      enddo
+
+      do i=1,iip1
+         rlonudeg(i)=rlonu(i)*180./pi + 360.
+         rlonvdeg(i)=rlonv(i)*180./pi + 360.
+      enddo
+
+
+      print*,'OK2'
+c  2 ----- OUVERTURE DE LA SORTIE NETCDF
+c ---------------------------------------------------
+c CREATION OUTPUT
+c ouverture fichier netcdf de sortie out
+        fich_out='grilles_gcm.nc'
+
+        status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out)
+        status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
+        status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
+        status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
+        status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
+
+
+      print*,'OK3'
+c   Longitudes en u
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim,
+     %  out_lonuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',
+     %  9,'Longitude en u')
+
+c   Longitudes en v
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim,
+     %  out_lonvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name',
+     %  9,'Longitude en v')
+
+c   Latitude en u
+        status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim,
+     %  out_latuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name',
+     %  8,'Latitude en u')
+
+c  Latitude en v
+        status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim,
+     %  out_latvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name',
+     %  8,'Latitude en v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonudim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+c   ecriture de la grille v
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latvdim
+        status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+
+      print*,'OK4'
+        status=NF_ENDDEF(ncid_out)
+c 5) ----- FERMETURE DES FICHIERS NETCDF------------------
+c --------------------------------------------------------
+c 3-b- Ecriture de la grille pour la sortie
+c rajoute l'ecriture de la grille
+
+#ifdef NC_DOUBLE
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#else
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#endif
+
+        start(1)=1
+        start(2)=1
+        start(3)=1
+        start(4)=1
+
+        count(1)=iim+1
+        count(2)=jjm+1
+        count(3)=1
+        count(4)=1
+
+        do j=1,jjm+1
+           do i=1,iim+1
+              temp(i,j)=mod(i,2)+mod(j,2)
+           enddo
+        enddo
+
+#ifdef NC_DOUBLE
+        status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start,
+     s  count,temp)
+#else
+        status=NF_PUT_VARA_REAL(ncid_out,out_varid,start,
+     s  count,temp)
+#endif
+
+
+c fermeture du fichier netcdf
+        call ncclos(ncid_out,rcode_out)
+        write(*,*) 'Fermeture: ',fich_out
+
+
+      print*,'OK5'
+c   Ecriture grads
+      open (20,file='grille.dat',form='unformatted',access='direct'
+     s      ,recl=4*ip1jmp1)
+      write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
+      write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
+      do j=2,jjm
+         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
+c        dlat2(j)=180.*fyprim(float(j))/pi
+      enddo
+      do i=2,iip1
+         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
+c        dlon2(i)=180.*fxprim(float(i))/pi
+      enddo
+      do j=2,jjm
+         dykm=(rlatv(j)-rlatv(j-1))*6400.
+         acoslat=6400.*cos(rlatu(j))
+         do i=2,iip1
+            dxkm=acoslat*(rlonu(i)-rlonu(i-1))
+            resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm)
+         enddo
+         resol(1,j)=resol(iip1,j)
+      enddo
+      write(20,rec=3) resol
+      dlon1(1)=dlon1(iip1)
+      dlon2(1)=dlon2(iip1)
+      write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=5) ((dlon1(i)*pi/180.*0.001*
+     s   cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1)
+      write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1)
+      write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1)
+      write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1)
+
+      print*,'I, LON, DX (km)'
+      do i=1,iip1
+         print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001*
+     s   cos(clat*pi/180.)*rad
+      enddo
+      print*,'J, LAT, DY (km)'
+      do j=1,jjp1
+         print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad
+      enddo
+
+      open (21,file='grille.ctl',form='formatted')
+
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      write(21,'(a5,1x,a40)')
+     &       'DSET ','^grille.dat'
+
+      write(21,'(a12)') 'UNDEF 1.0E30'
+      write(21,'(a5,1x,a40)') 'TITLE ','grille'
+      call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF')
+      call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF')
+      call formcoord(21,1,0.,1.,.false.,'ZDEF')
+      write(21,'(a4,i10,a30)')
+     &       'TDEF ',1,' LINEAR 23OCT1994 3hr '
+      write(21,'(a4,2x,i5)') 'VARS',9
+      write(21,'(a18)') 'grille 0 99 grille'
+      write(21,'(a18)') 'gril   0 99 gril  '
+      write(21,'(a29)') 'resol   0 99 resolution (km)  '
+      write(21,'(a18)') 'dlon1  0 99 dlon1 '
+      write(21,'(a20)') 'dx     0 99 dx (km) '
+      write(21,'(a18)') 'dlon2  0 99 dlon2 '
+      write(21,'(a18)') 'dlat1  0 99 dlat1 '
+      write(21,'(a20)') 'dy     0 99 dy (km) '
+      write(21,'(a18)') 'dlat2  0 99 dlat2 '
+      write(21,'(a7)') 'ENDVARS'
+
+
+
+
+
+      print*,'OK6'
+	end
+
+
+
+        subroutine handle_err(status)
+#include "netcdf.inc"
+
+
+        integer status
+        print *,'handle code err: ',NF_NOERR
+        IF (status.NE.nf_noerr) THEN
+                print *,NF_STRERROR(status)
+                stop 'stopped'
+        ENDIF
+        END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/groupe_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/groupe_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/groupe_p.F	(revision 984)
@@ -0,0 +1,130 @@
+      subroutine groupe_p(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      USE parallel
+      implicit none
+
+c   sous-programme servant a fitlrer les champs de flux de masse aux
+c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+c   et a mesure qu'on se rapproche du pole.
+c
+c   en entree: pext, pbaru et pbarv
+c
+c   en sortie:  pbarum,pbarvm et wm.
+c
+c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+c   pas besoin de w en entree.
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "comvert.h"
+
+      integer ngroup
+      parameter (ngroup=3)
+
+
+      real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
+      real pext(iip1,jjp1,llm)
+
+      real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
+      real wm(iip1,jjp1,llm)
+
+      real,save :: zconvm(iip1,jjp1,llm)
+      real,save :: zconvmm(iip1,jjp1,llm)
+
+      real uu
+
+      integer i,j,l
+
+      logical firstcall
+      save firstcall
+c$OMP THREADPRIVATE(firstcall)
+
+      data firstcall/.true./
+      integer ijb,ije,jjb,jje
+      
+      if (firstcall) then
+         if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point'
+         firstcall=.false.
+      endif
+
+c   Champs 1D
+
+      call convflu_p(pbaru,pbarv,llm,zconvm)
+
+c
+c      call scopy(ijp1llm,zconvm,1,zconvmm,1)
+c      call scopy(ijmllm,pbarv,1,pbarvm,1)
+      
+      jjb=jj_begin
+      jje=jj_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
+      enddo
+c$OMP END DO NOWAIT
+
+      call groupeun_p(jjp1,llm,jjb,jje,zconvmm)
+      
+      jjb=jj_begin-1
+      jje=jj_end
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud)  jje=jj_end-1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+        pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
+      enddo
+c$OMP END DO NOWAIT
+
+      call groupeun_p(jjm,llm,jjb,jje,pbarvm)
+
+c   Champs 3D
+   
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_nord) jjb=jj_begin+1
+      if (pole_sud)  jje=jj_end-1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      do l=1,llm
+         do j=jjb,jje
+            uu=pbaru(iim,j,l)
+            do i=1,iim
+               uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+               pbarum(i,j,l)=uu
+c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+c    *                      yflu(i,j,l)-yflu(i,j-1,l)
+            enddo
+            pbarum(iip1,j,l)=pbarum(1,j,l)
+         enddo
+      enddo
+c$OMP END DO NOWAIT
+c    integration de la convergence de masse de haut  en bas ......
+   
+      jjb=jj_begin
+      jje=jj_end
+
+c$OMP BARRIER
+c$OMP MASTER      
+      do  l = llm-1,1,-1
+          do j=jjb,jje
+             do i=1,iip1
+                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+             enddo
+          enddo
+      enddo
+
+      if (.not. pole_sud) then
+        zconvmm(:,jj_end+1,:)=0
+cym	wm(:,jj_end+1,:)=0
+      endif
+      
+c$OMP END MASTER
+c$OMP BARRIER      
+
+      CALL vitvert_p(zconvmm(1,1,1),wm(1,1,1))
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/groupeun_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/groupeun_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/groupeun_p.F	(revision 984)
@@ -0,0 +1,77 @@
+      subroutine groupeun_p(jjmax,llmax,jjb,jje,q)
+      USE parallel
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      integer jjmax,llmax,jjb,jje
+      real q(iip1,jjmax,llmax)
+
+      integer ngroup
+      parameter (ngroup=3)
+
+      real airen,airecn,qn
+      real aires,airecs,qs
+
+      integer i,j,l,ig,j1,j2,i0,jd
+
+Champs 3D
+      jd=jjp1-jjmax
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,llm
+      j1=1+jd
+      j2=2
+      do ig=1,ngroup
+         do j=j1-jd,j2-jd
+c           print*,'groupe ',ig,'  j= ',j,2**(ngroup-ig+1),'pts groupes'
+            if ( j >= jjb .AND. j <= jje) THEN
+             
+              do i0=1,iim,2**(ngroup-ig+1)
+                 
+                 airen=0.
+                 airecn=0.
+                 qn=0.
+                 
+                 do i=i0,i0+2**(ngroup-ig+1)-1
+                    airen=airen+aire(i,j)
+                    qn=qn+q(i,j,l)
+                 enddo
+                 airecn=0.
+                 do i=i0,i0+2**(ngroup-ig+1)-1
+                   q(i,j,l)=qn*aire(i,j)/airen
+                 enddo
+              enddo
+              q(iip1,j,l)=q(1,j,l)
+              
+            endif
+            
+            if ( jjp1-j+1-jd >= jjb .AND. jjp1-j+1-jd <= jje) THEN
+             
+              do i0=1,iim,2**(ngroup-ig+1)
+                 aires=0.
+                 airecs=0.
+                 qs=0.
+                 do i=i0,i0+2**(ngroup-ig+1)-1
+                    aires=aires+aire(i,jjp1-j+1)
+                    qs=qs+q(i,jjp1-j+1-jd,l)
+                 enddo
+                 airecs=0.
+                 do i=i0,i0+2**(ngroup-ig+1)-1
+                   q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires
+                 enddo
+              enddo
+              q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
+           
+            endif
+         enddo
+             
+           j1=j2+1
+           j2=j2+2**ig
+      enddo
+      enddo
+c$OMP END DO NOWAIT
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/guide.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/guide.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/guide.h	(revision 984)
@@ -0,0 +1,39 @@
+!
+! $Header$
+!
+      real tau_min_u,tau_max_u
+      real tau_min_v,tau_max_v
+      real tau_min_T,tau_max_T
+      real tau_min_q,tau_max_q
+      real tau_min_P,tau_max_P
+      real aire_min,aire_max
+
+
+      logical guide_u,guide_v,guide_T,guide_Q,guide_P
+
+      real lat_min_guide,lat_max_guide
+
+
+c     data tau_min_u,tau_max_u/0.02,10./
+c     data tau_min_v,tau_max_v/0.02,10./
+c     data tau_min_T,tau_max_T/0.02,10./
+c     data tau_min_q,tau_max_q/0.02,10./
+c     data tau_min_P,tau_max_P/0.02,10./
+c
+      LOGICAL ncep,ini_anal
+      integer online
+
+c     data online/1/
+c     data ncep,ini_anal/.false.,.true./
+
+      common/comguide/
+     s tau_min_u,tau_max_u,
+     s tau_min_v,tau_max_v,
+     s tau_min_T,tau_max_T,
+     s tau_min_q,tau_max_q,
+     s tau_min_P,tau_max_P,
+     s aire_min,aire_max,
+     s lat_min_guide,lat_max_guide,
+     s ncep,ini_anal,
+     s online,
+     s guide_u,guide_v,guide_T,guide_Q,guide_P
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/guide_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/guide_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/guide_p.F	(revision 984)
@@ -0,0 +1,565 @@
+!
+! $Header$
+!
+      subroutine guide_pp(itau,ucov,vcov,teta,q,masse,ps)
+      USE parallel
+
+      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:  F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+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 shema de Van-leer pour l'advection de
+c         q  , en faisant iadv = 10  dans   traceur  (29/04/97) .
+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 "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "tracstoke.h"
+#include "guide.h"
+
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+
+c   common passe pour des sorties
+      real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm)
+      common/comdxdy/dxdys,dxdyu,dxdyv
+
+c   variables dynamiques pour les reanalyses.
+      REAL ucovrea1(ip1jmp1,llm),vcovrea1(ip1jm,llm) !vts cov reas
+      REAL tetarea1(ip1jmp1,llm)             ! temp pot  reales
+      REAL qrea1(ip1jmp1,llm)             ! temp pot  reales
+      REAL masserea1(ip1jmp1,llm)             ! masse
+      REAL psrea1(ip1jmp1)             ! ps
+      REAL ucovrea2(ip1jmp1,llm),vcovrea2(ip1jm,llm) !vts cov reas
+      REAL tetarea2(ip1jmp1,llm)             ! temp pot  reales
+      REAL qrea2(ip1jmp1,llm)             ! temp pot  reales
+      REAL masserea2(ip1jmp1,llm)             ! masse
+      REAL psrea2(ip1jmp1)             ! ps
+      real latmin
+
+      real alpha_q(ip1jmp1)
+      real alpha_T(ip1jmp1),alpha_P(ip1jmp1)
+      real alpha_u(ip1jmp1),alpha_v(ip1jm)
+      real dday_step,toto,reste,itau_test
+      INTEGER step_rea,count_no_rea
+
+c      real aire_min,aire_max
+      integer ilon,ilat
+      real factt,ztau(ip1jmp1)
+
+      INTEGER itau,ij,l,i,j
+      integer ncidpl,varidpl,nlev,status
+      integer rcod,rid 
+      real ditau,tau,a
+      save nlev
+
+c  TEST SUR QSAT
+      real p(ip1jmp1,llmp1),pk(ip1jmp1,llm),pks(ip1jmp1)
+      real pkf(ip1jmp1,llm)
+      real pres(ip1jmp1,llm)
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+
+      real qsat(ip1jmp1,llm)
+      real unskap
+      real tnat(ip1jmp1,llm)
+ccccccccccccccccc
+
+
+      LOGICAL first
+      save first
+      data first/.true./
+
+      save ucovrea1,vcovrea1,tetarea1,masserea1,psrea1,qrea1
+      save ucovrea2,vcovrea2,tetarea2,masserea2,psrea2,qrea2
+
+      save alpha_T,alpha_q,alpha_u,alpha_v,alpha_P,itau_test
+      save step_rea,count_no_rea
+
+      character*10 file
+      integer igrads
+      real dtgrads
+      save igrads,dtgrads
+      data igrads,dtgrads/2,100./
+      integer :: ijb,ije,jjn
+
+C-----------------------------------------------------------------------
+c calcul de l'humidite saturante
+C-----------------------------------------------------------------------
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+      
+      print*,'OK0'
+      CALL pression_p( ip1jmp1, ap, bp, ps, p )
+      call massdair_p(p,masse)
+      print*,'OK1'
+      CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
+      print*,'OK2'
+      tnat(ijb:ije,:)=pk(ijb:ije,:)*teta(ijb:ije,:)/cpp
+      print*,'OK3'
+      unskap   = 1./ kappa
+      pres(ijb:ije,:)=preff*(pk(ijb:ije,:)/cpp)**unskap
+      print*,'OK4'
+      call q_sat(iip1*jjn*llm,tnat(ijb:ije,:),pres(ijb:ije,:),
+     .            qsat(ijb:ije,:))
+
+C-----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c   initialisations pour la lecture des reanalyses.
+c    alpha determine la part des injections de donnees a chaque etape
+c    alpha=1 signifie pas d'injection
+c    alpha=0 signifie injection totale
+c-----------------------------------------------------------------------
+
+      print*,'ONLINE=',online
+      if(online.eq.-1) then
+          return
+      endif
+
+      if (first) then
+
+         print*,'initialisation du guide '
+         call conf_guide
+         print*,'apres conf_guide'
+
+         file='guide'
+	 
+	 if (mpi_rank==0) then
+         call inigrads(igrads,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtgrads,file,'dyn_zon ')
+         endif
+	 
+         print*
+     s   ,'1: en-ligne, 0: hors-ligne (x=x_rea), -1: climat (x=x_gcm)'
+
+         if(online.eq.-1) return
+         if (online.eq.1) then
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c  Constantes de temps de rappel en jour
+c  0.1 c'est en gros 2h30. 
+c  1e10  est une constante infinie donc en gros pas de guidage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   coordonnees du centre du zoom
+           call coordij(clon,clat,ilon,ilat)
+c   aire de la maille au centre du zoom
+           aire_min=aire(ilon+(ilat-1)*iip1)
+c   aire maximale de la maille
+           aire_max=0.
+           do ij=1,ip1jmp1
+              aire_max=max(aire_max,aire(ij))
+           enddo
+C  factt = pas de temps en fraction de jour
+           factt=dtvr*iperiod/daysec
+
+c     subroutine tau2alpha(type,im,jm,factt,taumin,taumax,alpha)
+           call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+           call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+           call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+           call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+           call tau2alpha(1,iip1,jjp1,factt,tau_min_q,tau_max_q,alpha_q)
+
+           call dump2d(iip1,jjp1,aire,'AIRE MAILLe ')
+           call dump2d(iip1,jjp1,alpha_u,'COEFF U   ')
+           call dump2d(iip1,jjp1,alpha_T,'COEFF T   ')
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   Cas ou on force exactement par les variables analysees
+         else
+            alpha_T=0.
+            alpha_u=0.
+            alpha_v=0.
+            alpha_P=0.
+c           physic=.false.
+         endif
+
+         itau_test=1001
+         step_rea=1
+         count_no_rea=0
+         ncidpl=-99
+c    itau_test    montre si l'importation a deja ete faite au rang itau
+c lecture d'un fichier netcdf pour determiner le nombre de niveaux
+         IF (mpi_rank==0) THEN
+	
+         if (guide_u) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('u.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (guide_v) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('v.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (guide_T) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('T.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (guide_Q) then
+           if (ncidpl.eq.-99) ncidpl=NCOPN('hur.nc',NCNOWRIT,rcod)
+         endif
+c
+         if (ncep) then
+          status=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+         else
+          status=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+         endif
+          status=NF_INQ_DIMLEN(ncidpl,rid,nlev)
+         print *,'nlev', nlev 
+          call ncclos(ncidpl,rcod)
+	 
+	 ENDIF
+	 
+c   Lecture du premier etat des reanalyses.
+         call Gather_Field(ps,ip1jmp1,1,0)
+
+	 if (mpi_rank==0) then
+	 
+	 call read_reanalyse(1,ps
+     s   ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev)
+         qrea2(:,:)=max(qrea2(:,:),0.1)
+	 
+	 endif
+	 
+	 call Broadcast_Field(ucovrea2,ip1jmp1,llm,0)
+	 call Broadcast_Field(vcovrea2,ip1jm,llm,0)
+	 call Broadcast_Field(tetarea2,ip1jmp1,llm,0)
+	 call Broadcast_Field(qrea2,ip1jmp1,llm,0)
+	 call Broadcast_Field(masserea2,ip1jmp1,llm,0)
+	 call Broadcast_Field(psrea2,ip1jmp1,1,0)
+	 
+
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+
+      endif ! first
+c
+C-----------------------------------------------------------------------
+C----- IMPORTATION DES VENTS,PRESSION ET TEMPERATURE REELS:
+C-----------------------------------------------------------------------
+
+      ditau=real(itau)
+      DDAY_step=real(day_step)
+      write(*,*)'ditau,dday_step'
+      write(*,*)ditau,dday_step
+      toto=4*ditau/dday_step
+      reste=toto-aint(toto)
+c     write(*,*)'toto,reste',toto,reste
+
+      if (reste.eq.0.) then
+        if (itau_test.eq.itau) then
+          write(*,*)'deuxieme passage de advreel a itau=',itau
+          stop
+        else
+        vcovrea1(:,:)=vcovrea2(:,:)
+        ucovrea1(:,:)=ucovrea2(:,:)
+        tetarea1(:,:)=tetarea2(:,:)
+        qrea1(:,:)=qrea2(:,:)
+
+          print*,'LECTURE REANALYSES, pas ',step_rea
+     s         ,'apres ',count_no_rea,' non lectures'
+           step_rea=step_rea+1
+           itau_test=itau
+	   
+       call Gather_Field(ps,ip1jmp1,1,0)
+
+       if (mpi_rank==0) then
+           call read_reanalyse(step_rea,ps
+     s     ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev)
+         qrea2(:,:)=max(qrea2(:,:),0.1)
+       endif
+
+       call Broadcast_Field(ucovrea2,ip1jmp1,llm,0)
+       call Broadcast_Field(vcovrea2,ip1jm,llm,0)
+       call Broadcast_Field(tetarea2,ip1jmp1,llm,0)
+       call Broadcast_Field(qrea2,ip1jmp1,llm,0)
+       call Broadcast_Field(masserea2,ip1jmp1,llm,0)
+       call Broadcast_Field(psrea2,ip1jmp1,1,0)
+       
+       factt=dtvr*iperiod/daysec
+       ztau(:)=factt/max(alpha_T(:),1.e-10)
+      
+       if (mpi_rank==0) then
+         call wrgrads(igrads,1,aire   ,'aire      ','aire      ' )
+         call wrgrads(igrads,1,dxdys  ,'dxdy      ','dxdy      ' )
+         call wrgrads(igrads,1,alpha_u,'au        ','au        ' )
+         call wrgrads(igrads,1,alpha_T,'at        ','at        ' )
+         call wrgrads(igrads,1,ztau,'taut      ','taut      ' )
+         call wrgrads(igrads,llm,ucov,'u         ','u         ' )
+         call wrgrads(igrads,llm,ucovrea2,'ua        ','ua        ' )
+         call wrgrads(igrads,llm,teta,'T         ','T         ' )
+         call wrgrads(igrads,llm,tetarea2,'Ta        ','Ta        ' )
+         call wrgrads(igrads,llm,qrea2,'Qa        ','Qa        ' )
+         call wrgrads(igrads,llm,q,'Q         ','Q         ' )
+         call wrgrads(igrads,llm,qsat,'QSAT      ','QSAT      ' )
+      endif
+      
+        endif
+      else
+        count_no_rea=count_no_rea+1
+      endif
+ 
+C-----------------------------------------------------------------------
+c   Guidage
+c    x_gcm = a * x_gcm + (1-a) * x_reanalyses
+C-----------------------------------------------------------------------
+
+       if(ini_anal) print*,'ATTENTION !!! ON PART DU GUIDAGE'
+
+      ditau=real(itau)
+      dday_step=real(day_step)
+
+
+      tau=4*ditau/dday_step
+      tau=tau-aint(tau)
+
+c  ucov
+      ijb=ij_begin
+      ije=ij_end
+      
+      if (guide_u) then
+         do l=1,llm
+            do ij=ijb,ije
+                a=(1.-tau)*ucovrea1(ij,l)+tau*ucovrea2(ij,l)
+                ucov(ij,l)=(1.-alpha_u(ij))*ucov(ij,l)+alpha_u(ij)*a
+                if (first.and.ini_anal) ucov(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c  teta
+      if (guide_T) then
+         do l=1,llm
+            do ij=ijb,ije
+                a=(1.-tau)*tetarea1(ij,l)+tau*tetarea2(ij,l)
+                teta(ij,l)=(1.-alpha_T(ij))*teta(ij,l)+alpha_T(ij)*a
+                if (first.and.ini_anal) teta(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c  P
+      if (guide_P) then
+         do ij=ijb,ije
+             a=(1.-tau)*psrea1(ij)+tau*psrea2(ij)
+             ps(ij)=(1.-alpha_P(ij))*ps(ij)+alpha_P(ij)*a
+             if (first.and.ini_anal) ps(ij)=a
+         enddo
+         CALL pression_p(ip1jmp1,ap,bp,ps,p)
+         CALL massdair_p(p,masse)
+      endif
+
+
+c  q
+      if (guide_Q) then
+         do l=1,llm
+            do ij=ijb,ije
+                a=(1.-tau)*qrea1(ij,l)+tau*qrea2(ij,l)
+c   hum relative en % -> hum specif
+                a=qsat(ij,l)*a*0.01
+                q(ij,l)=(1.-alpha_Q(ij))*q(ij,l)+alpha_Q(ij)*a
+                if (first.and.ini_anal) q(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c vcov
+      if (pole_sud) ije=ij_end-iip1
+      
+      if (guide_v) then
+         do l=1,llm
+            do ij=ijb,ije
+                a=(1.-tau)*vcovrea1(ij,l)+tau*vcovrea2(ij,l)
+                vcov(ij,l)=(1.-alpha_v(ij))*vcov(ij,l)+alpha_v(ij)*a
+                if (first.and.ini_anal) vcov(ij,l)=a
+            enddo
+         enddo
+      endif
+
+c     call dump2d(iip1,jjp1,tetarea1,'TETA REA 1     ')
+c     call dump2d(iip1,jjp1,tetarea2,'TETA REA 2     ')
+c     call dump2d(iip1,jjp1,teta,'TETA           ')
+
+         first=.false.
+
+      return
+      end
+
+c=======================================================================
+      subroutine tau2alpha(type,pim,pjm,factt,taumin,taumax,alpha)
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "guide.h"
+#include "serre.h"
+
+c   arguments :
+      integer type
+      integer pim,pjm
+      real factt,taumin,taumax,dxdymin,dxdymax
+      real dxdy_,alpha(pim,pjm)
+      real dxdy_min,dxdy_max
+
+c  local :
+      real alphamin,alphamax,gamma,xi
+      save gamma
+      integer i,j,ilon,ilat
+
+      logical first
+      save first
+      data first/.true./
+
+      real cus(iip1,jjp1),cvs(iip1,jjp1)
+      real cuv(iip1,jjm),cvu(iip1,jjp1)
+      real zdx(iip1,jjp1),zdy(iip1,jjp1)
+
+      real zlat
+      real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm)
+      common/comdxdy/dxdys,dxdyu,dxdyv
+
+      if (first) then
+         do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+         enddo
+         do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+         enddo
+         do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+         enddo
+         do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+         enddo
+         do j=1,jjp1
+            do i=1,iim
+               dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+            enddo
+            dxdyu(iip1,j)=dxdyu(1,j)
+         enddo
+         do j=1,jjm
+            do i=1,iip1
+               dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+            enddo
+         enddo
+
+         call dump2d(iip1,jjp1,dxdys,'DX2DY2 SCAL  ')
+         call dump2d(iip1,jjp1,dxdyu,'DX2DY2 U     ')
+         call dump2d(iip1,jjp1,dxdyv,'DX2DY2 v     ')
+
+c   coordonnees du centre du zoom
+           call coordij(clon,clat,ilon,ilat)
+c   aire de la maille au centre du zoom
+           dxdy_min=dxdys(ilon,ilat)
+c   dxdy maximale de la maille
+           dxdy_max=0.
+           do j=1,jjp1
+              do i=1,iip1
+                 dxdy_max=max(dxdy_max,dxdys(i,j))
+              enddo
+           enddo
+
+         if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+             print*,'ATTENTION modele peu zoome'
+             print*,'ATTENTION on prend une constante de guidage cste'
+             gamma=0.
+         else
+            gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+            print*,'gamma=',gamma
+            if (gamma.lt.1.e-5) then
+              print*,'gamma =',gamma,'<1e-5'
+              stop
+            endif
+            print*,'gamma=',gamma
+            gamma=log(0.5)/log(gamma)
+         endif
+      endif
+
+      alphamin=factt/taumax
+      alphamax=factt/taumin
+
+      do j=1,pjm
+         do i=1,pim
+            if (type.eq.1) then
+               dxdy_=dxdys(i,j)
+               zlat=rlatu(j)*180./pi
+            elseif (type.eq.2) then
+               dxdy_=dxdyu(i,j)
+               zlat=rlatu(j)*180./pi
+            elseif (type.eq.3) then
+               dxdy_=dxdyv(i,j)
+               zlat=rlatv(j)*180./pi
+            endif
+          if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+c  pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+             alpha(i,j)=alphamin
+          else
+            xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+            xi=min(xi,1.)
+            if(lat_min_guide.le.zlat .and. zlat.le.lat_max_guide) then
+               alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+            else
+               alpha(i,j)=0.
+            endif
+          endif
+         enddo
+      enddo
+
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/heavyside.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/heavyside.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/heavyside.F	(revision 984)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+c
+c
+       FUNCTION heavyside(a)
+
+c      ...   P. Le Van  ....
+c
+       IMPLICIT NONE
+
+       REAL*8 heavyside , a
+
+       IF ( a.LE.0. )  THEN
+         heavyside = 0.
+       ELSE
+         heavyside = 1.
+       ENDIF
+
+       RETURN
+       END
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniacademic.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniacademic.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniacademic.F	(revision 984)
@@ -0,0 +1,194 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE iniacademic(nq,vcov,ucov,teta,q,masse,ps,phis,time_0)
+
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 15/01/93
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "academic.h"
+#include "ener.h"
+#include "temps.h"
+#include "control.h"
+
+c   Arguments:
+c   ----------
+
+      integer nq
+      real time_0
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle
+      REAL q(ip1jmp1,llm,nq)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+
+
+
+
+
+c   Local:
+c   ------
+
+      REAL ddsin,tetarappelj,tetarappell,zsig
+      real tetajl(jjp1,llm)
+      INTEGER i,j,l,lsup,ij
+
+      real zz,ran1
+      integer idum
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr
+
+c-----------------------------------------------------------------------
+
+c
+      time_0=0.
+
+      im         = iim
+      jm         = jjm
+      day_ini    = 0
+      omeg       = 4.*asin(1.)/86400.
+      rad    = 6371229.
+      g      = 9.8
+      daysec = 86400.
+      dtvr    = daysec/FLOAT(day_step)
+      zdtvr=dtvr
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      preff     = 101325.
+      pa        =  50 000.
+      etot0      = 0.
+      ptot0      = 0.
+      ztot0      = 0.
+      stot0      = 0.
+      ang0       = 0.
+      pa         = 0.
+
+      CALL inicons0
+      CALL inigeom
+      CALL inifilr
+
+      ps=0.
+      phis=0.
+c---------------------------------------------------------------------
+
+      taurappel=10.*daysec
+
+c---------------------------------------------------------------------
+c   Calcul de la temperature potentielle :
+c   --------------------------------------
+
+      DO l=1,llm
+       zsig=ap(l)/preff+bp(l)
+       if (zsig.gt.0.3) then
+         lsup=l
+         tetarappell=1./8.*(-log(zsig)-.5)
+         DO j=1,jjp1
+            ddsin=sin(rlatu(j))-sin(pi/20.)
+            tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell)
+         ENDDO
+        else
+c   Choix isotherme au-dessus de 300 mbar
+         do j=1,jjp1
+            tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa
+         enddo
+        endif
+      ENDDO
+
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iip1
+               ij=(j-1)*iip1+i
+               tetarappel(ij,l)=tetajl(j,l)
+            enddo
+         enddo
+      enddo
+
+c     call dump2d(jjp1,llm,tetajl,'TEQ   ')
+
+      ps=1.e5
+      phis=0.
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+      CALL massdair(p,masse)
+
+c  intialisation du vent et de la temperature
+      teta(:,:)=tetarappel(:,:)
+      CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
+      call ugeostr(phi,ucov)
+      vcov=0.
+      q(:,:,1   )=1.e-10
+      q(:,:,2   )=1.e-15
+      q(:,:,3:nq)=0.
+
+
+c   perturbation al\351atoire sur la temp\351rature
+      idum  = -1
+      zz = ran1(idum)
+      idum  = 0
+      do l=1,llm
+         do ij=iip2,ip1jm
+            teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum))
+         enddo
+      enddo
+
+      do l=1,llm
+         do ij=1,ip1jmp1,iip1
+            teta(ij+iim,l)=teta(ij,l)
+         enddo
+      enddo
+
+
+
+c     PRINT *,' Appel test_period avec tetarappel '
+c     CALL  test_period ( ucov,vcov,tetarappel,q,p,phis )
+c     PRINT *,' Appel test_period avec teta '
+c     CALL  test_period ( ucov,vcov,teta,q,p,phis )
+
+c   initialisation d'un traceur sur une colonne
+      j=jjp1*3/4
+      i=iip1/2
+      ij=(j-1)*iip1+i
+      q(ij,:,3)=1.
+
+      return
+      END
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniadvtrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniadvtrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniadvtrac.F	(revision 984)
@@ -0,0 +1,248 @@
+!
+! $Header$
+!
+c
+c
+      subroutine iniadvtrac(nq)
+      USE ioipsl
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c   Modif special traceur F.Forget 05/94
+c   Modif M-A Filiberti 02/02 lecture de traceur.def
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c   ... modification de l'integration de q ( 26/04/94 ) ....
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+C
+#include "dimensions.h"
+#include "advtrac.h"
+#include "control.h"
+
+c   local
+      character*3 descrq(30)
+      character*1 txts(3)
+      character*2 txtp(9)
+      character*13 str1,str2,str3
+
+      integer nq,iq,iiq,iiiq,ierr,ii
+      integer lnblnk
+      external lnblnk
+
+      data txts/'x','y','z'/
+      data txtp/'x','y','z','xx','xy','xz','yy','yz','zz'/
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+      descrq(14)='VLH'
+      descrq(10)='VL1'
+      descrq(11)='VLP'
+      descrq(12)='FH1'
+      descrq(13)='FH2'
+      descrq(16)='PPM'
+      descrq(17)='PPS'
+      descrq(18)='PPP'
+      descrq(20)='SLP'
+      descrq(30)='PRA'
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         CALL init_transport( 
+     $        hadv_flg,
+     $        vadv_flg,
+     $        conv_flg,
+     $        pbl_flg,
+     $        tracnam)
+#endif
+      END IF
+c-----------------------------------------------------------------------
+c        Choix  des schemas d'advection pour l'eau et les traceurs
+c
+c     iadv = 1    schema  transport type "humidite specifique LMD"
+c     iadv = 2    schema   amont
+c     iadv = 14    schema  Van-leer + humidite specifique 
+c                            Modif F.Codron
+c     iadv = 10   schema  Van-leer (retenu pour l'eau vapeur et liquide)
+c     iadv = 11   schema  Van-Leer pour hadv et version PPM (Monotone) pour vadv
+c     iadv = 12   schema  Frederic Hourdin I
+c     iadv = 13   schema  Frederic Hourdin II
+c     iadv = 16   schema  PPM Monotone(Collela & Woodward 1984)
+c     iadv = 17   schema  PPM Semi Monotone (overshoots autorisés)
+c     iadv = 18   schema  PPM Positif Defini (overshoots undershoots autorisés)
+c     iadv = 20   schema  Slopes
+c     iadv = 30   schema  Prather
+c
+c        Dans le tableau q(ij,l,iq) : iq = 1  pour l'eau vapeur
+c                                     iq = 2  pour l'eau liquide
+c        Et eventuellement            iq = 3,nqmx pour les autres traceurs
+c
+c        iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+C------------------------------------------------------------------------
+c     Choix du schema d'advection
+c------------------------------------------------------------------
+c choix par defaut = van leer pour tous les traceurs
+      do iq=1,nqmx
+       iadv(iq)=10
+       str1(1:1)='q'
+       if (nqmx.le.99) then
+       WRITE(str1(2:3),'(i2.2)') iq
+       else
+       WRITE(str1(2:4),'(i3.3)') iq
+       endif
+       tnom(iq)=str1
+       tname(iq)=tnom(iq) 
+       str2=tnom(iq) 
+       ttext(iq)=str2(1:lnblnk(str2))//descrq(iadv(iq))
+      end do
+      nq=nqmx
+c------------------------------------------------------------------
+c     Choix du schema pour l'advection
+c    dans fichier traceur.def
+c------------------------------------------------------------------
+
+      IF (config_inca /= 'none') THEN
+C le module de chimie fournit les noms des traceurs
+C et les schemas d'advection associes.
+         tnom(1)='H2Ov'
+         tnom(2)='H2Ol'
+         nq=nbtrac+2
+      
+       if (nq.gt.nqmx) then
+       print*,'nombre de traceurs incompatible INCA/LMDZT', nq, nbtrac
+       stop
+       endif
+      do iq =3,nq
+      tnom(iq)=tracnam(iq-2)
+      end do
+      do iq =1,nq
+      hadv(iq)= hadv_flg(iq) 
+      vadv(iq)= vadv_flg(iq) 
+      end do
+      ELSE  ! config_inca=none
+         print*,'ouverture de traceur.def'
+         open(90,file='traceur.def',form='formatted',status='old',
+     s        iostat=ierr)
+      if(ierr.eq.0) then
+        print*,'ouverture de traceur.def ok'
+        read(90,*) nq
+        print*,'nombre de traceurs ',nq
+        if (nq.gt.nqmx) then
+          print*,'nombre de traceurs trop important'
+          print*,'verifier traceur.def'
+          stop
+        endif
+C
+        do iq=1,nq
+          read(90,999) hadv(iq),vadv(iq),tnom(iq)
+        end do
+        close(90)  
+        PRINT*,'lecture de traceur.def :'   
+        do iq=1,nq
+          write(*,*) hadv(iq),vadv(iq),tnom(iq)
+        end do       
+      else
+        print*,'pb ouverture traceur.def'
+        print*,'ATTENTION on prend des valeurs par defaut'
+        nq = 4
+        hadv(1) = 14
+        vadv(1) = 14
+        tnom(1) = 'H2Ov'
+        hadv(2) = 10
+        vadv(2) = 10
+        tnom(2) = 'H2Ol'
+        hadv(3) = 10
+        vadv(3) = 10
+        tnom(3) = 'RN'
+        hadv(4) = 10
+        vadv(4) = 10
+        tnom(4) = 'PB'
+      ENDIF
+      PRINT*,'Valeur de traceur.def :'
+      do iq=1,nq
+        write(*,*) hadv(iq),vadv(iq),tnom(iq)
+      end do       
+
+      END IF ! config_inca
+
+c a partir du nom court du traceur et du schema d'advection au detemine le nom long.
+        iiq=0
+        ii=0
+        do iq=1,nq 
+         iiq=iiq+1
+         if (hadv(iq).ne.vadv(iq)) then
+           if (hadv(iq).eq.10.and.vadv(iq).eq.16) then
+             iadv(iiq)=11
+           else
+             print*,'le choix des schemas d''advection H et V'
+             print*, 'est non disponible actuellement'
+             stop 
+           endif
+         else
+          iadv(iiq)=hadv(iq)
+         endif
+c verification nombre de traceurs
+          if (iadv(iiq).lt.20) then
+             ii=ii+1
+          elseif (iadv(iiq).eq.20) then
+             ii=ii+4
+          elseif (iadv(iiq).eq.30) then
+             ii=ii+10
+          endif
+ 
+         str1=tnom(iq)
+         tname(iiq)=tnom(iq)
+         IF (iadv(iiq).eq.0) THEN
+           ttext(iiq)=str1(1:lnblnk(str1))
+         ELSE
+           ttext(iiq)=str1(1:lnblnk(str1))//descrq(iadv(iiq))
+         ENDIF
+         str2=ttext(iiq)
+c   schemas tenant compte des moments d'ordre superieur.
+          if (iadv(iiq).eq.20) then
+             do iiiq=1,3
+               iiq=iiq+1
+               iadv(iiq)=-20
+               ttext(iiq)=str2(1:lnblnk(str2))//txts(iiiq)
+               tname(iiq)=str1(1:lnblnk(str1))//txts(iiiq)
+              enddo
+            elseif (iadv(iiq).eq.30) then
+              do iiiq=1,9
+               iiq=iiq+1
+               iadv(iiq)=-30
+               ttext(iiq)=str2(1:lnblnk(str2))//txtp(iiiq)
+               tname(iiq)=str1(1:lnblnk(str1))//txtp(iiiq)
+              enddo
+           endif
+        end do
+       if(ii.ne.nqmx) then
+       print*,'WARNING'
+       print*,'le nombre de traceurs et de moments eventuels'
+       print*,'est inferieur a nqmx '
+       endif
+       if (iiq.gt.nqmx) then
+       print*,'le choix des schemas est incompatible avec '
+       print*,'la dimension nqmx (nombre de traceurs)'
+       print*,'verifier traceur.def ou la namelist INCA'
+       print*,'ou recompiler avec plus de traceurs'
+       stop
+       endif
+      iiq=0
+      do iq=1,nqmx
+         if(iadv(iq).ge.0) then
+             iiq=iiq+1
+             niadv(iiq)=iq
+         endif
+      end do
+      return
+999   format (i2,1x,i2,1x,a8)
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inicons0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inicons0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inicons0.F	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+      SUBROUTINE inicons0
+      IMPLICIT NONE
+c
+c  P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "control.h"
+#include "comvert.h"
+#include "comdissnew.h"
+
+
+c
+c
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+      r       = cpp * kappa
+
+      PRINT*,' Cp R  kappa ',  cpp, r , kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniconst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniconst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniconst.F	(revision 984)
@@ -0,0 +1,57 @@
+!
+! $Header$
+!
+      SUBROUTINE iniconst
+
+      IMPLICIT NONE
+c
+c      P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "control.h"
+#include "comvert.h"
+
+
+c
+c
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+c
+
+      r       = cpp * kappa
+
+      PRINT*,' R  CP  Kappa ',  r , cpp,  kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inidissip.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inidissip.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inidissip.F	(revision 984)
@@ -0,0 +1,216 @@
+!
+! $Header$
+!
+      SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  ,
+     *                       tetagdiv,tetagrot,tetatemp             )
+c=======================================================================
+c   initialisation de la dissipation horizontale
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "control.h"
+
+      LOGICAL lstardis
+      INTEGER nitergdiv,nitergrot,niterh
+      REAL    tetagdiv,tetagrot,tetatemp
+      REAL fact,zvert(llm),zz
+      REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm)
+      REAL ullm,vllm,umin,vmin,zhmin,zhmax
+      REAL zllm,z1llm
+
+      INTEGER l,ij,idum,ii
+      REAL tetamin
+
+      REAL ran1
+
+
+c-----------------------------------------------------------------------
+c
+c   calcul des valeurs propres des operateurs par methode iterrative:
+c   -----------------------------------------------------------------
+
+      crot     = -1.
+      cdivu    = -1.
+      cdivh    = -1.
+
+c   calcul de la valeur propre de divgrad:
+c   --------------------------------------
+      idum = 0
+      DO l = 1, llm
+       DO ij = 1, ip1jmp1
+        deltap(ij,l) = 1.
+       ENDDO
+      ENDDO
+
+      idum  = -1
+      zh(1) = RAN1(idum)-.5
+      idum  = 0
+      DO ij = 2, ip1jmp1
+        zh(ij) = RAN1(idum) -.5
+      ENDDO
+
+      CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
+
+      CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+      IF ( zhmin .GE. zhmax  )     THEN
+         PRINT*,'  Inidissip  zh min max  ',zhmin,zhmax
+         STOP'probleme generateur alleatoire dans inidissip'
+      ENDIF
+
+      zllm = ABS( zhmax )
+      DO l = 1,50
+         IF(lstardis) THEN
+            CALL divgrad2(1,zh,deltap,niterh,zh)
+         ELSE
+            CALL divgrad (1,zh,niterh,zh)
+         ENDIF
+
+        CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+         zllm  = ABS( zhmax )
+         z1llm = 1./zllm
+         DO ij = 1,ip1jmp1
+            zh(ij) = zh(ij)* z1llm
+         ENDDO
+      ENDDO
+
+      IF(lstardis) THEN
+         cdivh = 1./ zllm
+      ELSE
+         cdivh = zllm ** ( -1./niterh )
+      ENDIF
+
+c   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
+c   -----------------------------------------------------------------
+      print*,'calcul des valeurs propres'
+
+      DO  20  ii = 1, 2
+c
+         DO ij = 1, ip1jmp1
+           zu(ij)  = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
+         DO ij = 1, ip1jm
+            zv(ij) = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
+
+         CALL minmax(iip1*jjp1,zu,umin,ullm )
+         CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+         ullm = ABS ( ullm )
+         vllm = ABS ( vllm )
+
+         DO  5  l = 1, 50
+            IF(ii.EQ.1) THEN
+ccccc             CALL covcont( 1,zu,zv,zu,zv )
+               IF(lstardis) THEN
+                  CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv )
+               ELSE
+                  CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv )
+               ENDIF
+            ELSE
+               IF(lstardis) THEN
+                  CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv )
+               ELSE
+                  CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv )
+               ENDIF
+            ENDIF
+
+            CALL minmax(iip1*jjp1,zu,umin,ullm )
+            CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+            ullm = ABS  ( ullm )
+            vllm = ABS  ( vllm )
+
+            zllm  = MAX( ullm,vllm )
+            z1llm = 1./ zllm
+            DO ij = 1, ip1jmp1
+              zu(ij) = zu(ij)* z1llm
+            ENDDO
+            DO ij = 1, ip1jm
+               zv(ij) = zv(ij)* z1llm
+            ENDDO
+ 5       CONTINUE
+
+         IF ( ii.EQ.1 ) THEN
+            IF(lstardis) THEN
+               cdivu  = 1./zllm
+            ELSE
+               cdivu  = zllm **( -1./nitergdiv )
+            ENDIF
+         ELSE
+            IF(lstardis) THEN
+               crot   = 1./ zllm
+            ELSE
+               crot   = zllm **( -1./nitergrot )
+            ENDIF
+         ENDIF
+
+ 20   CONTINUE
+
+c   petit test pour les operateurs non star:
+c   ----------------------------------------
+
+c     IF(.NOT.lstardis) THEN
+         fact    = rad*24./float(jjm)
+         fact    = fact*fact
+         PRINT*,'coef u ', fact/cdivu, 1./cdivu
+         PRINT*,'coef r ', fact/crot , 1./crot
+         PRINT*,'coef h ', fact/cdivh, 1./cdivh
+c     ENDIF
+
+c-----------------------------------------------------------------------
+c   variation verticale du coefficient de dissipation:
+c   --------------------------------------------------
+
+      DO l=1,llm
+         zvert(l)=1.
+      ENDDO
+
+      fact=2.
+c
+      DO l = 1, llm
+         zz      = 1. - preff/presnivs(l)
+         zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
+      ENDDO
+
+
+      PRINT*,'Constantes de temps de la diffusion horizontale'
+
+      tetamin =  1.e+6
+
+      DO l=1,llm
+        tetaudiv(l)   = zvert(l)/tetagdiv
+        tetaurot(l)   = zvert(l)/tetagrot
+        tetah(l)      = zvert(l)/tetatemp
+
+        IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
+        IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
+        IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
+      ENDDO
+
+      PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod
+      idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+      PRINT *,' INIDI tetamin idissip ',tetamin,idissip
+      idissip = MAX(iperiod,idissip)
+      dtdiss  = idissip * dtvr
+      PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss
+
+      DO l = 1,llm
+         PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l),
+     *                   dtdiss*tetah(l)
+      ENDDO
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inigeom.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inigeom.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inigeom.F	(revision 984)
@@ -0,0 +1,699 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE inigeom
+c
+c     Auteur :  P. Le Van
+c
+c   ............      Version  du 01/04/2001     ........................
+c
+c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+c     endroits que les aires aireij1,..aireij4 .
+
+c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "serre.h"
+#include "logic.h"
+#include "comdissnew.h"
+
+c-----------------------------------------------------------------------
+c   ....  Variables  locales   ....
+c
+      INTEGER  i,j,itmax,itmay,iter
+      REAL cvu(iip1,jjp1),cuv(iip1,jjm)
+      REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
+      REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm
+      REAL coslatm,coslatp,radclatm,radclatp
+      REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1),
+     *     cuij4(iip1,jjp1)
+      REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1),
+     *     cvij4(iip1,jjp1)
+      REAL rlonvv(iip1),rlatuu(jjp1)
+      REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) ,
+     *     yprimv(jjm),yprimu(jjp1)
+      REAL gamdi_gdiv, gamdi_grot, gamdi_h
+ 
+      REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),
+     ,  xprimp025(iip1)
+      SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
+      SAVE rlonm025,xprimm025,rlonp025,xprimp025
+
+      REAL      SSUM
+c
+c
+c   ------------------------------------------------------------------
+c   -                                                                -
+c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+c   -                                                                -
+c   ------------------------------------------------------------------
+c
+c      les coef. ( cu, cv ) permettent de passer des vitesses naturelles
+c      aux vitesses covariantes et contravariantes , ou vice-versa ...
+c
+c
+c     on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
+c             v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
+c
+c       on en tire :  u(covariant) = cu * cu * u(contravariant)
+c                     v(covariant) = cv * cv * v(contravariant)
+c
+c
+c     on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
+c                                                          =     =
+c                                           et   - jm/2    <  Y  < jm/2
+c                                                          =     =
+c
+c      ...................................................
+c      ...................................................
+c      .  x  est la longitude du point  en radians       .
+c      .  y  est la  latitude du point  en radians       .
+c      .                                                 .
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+c      .        aire(i,j) =  cu(i,j) * cv(j)             .
+c      .                                                 .
+c      . y, dx/dX, dy/dY calcules aux points concernes   .
+c      .                                                 .
+c      ...................................................
+c      ...................................................
+c
+c
+c
+c                                                           ,
+c    cv , bien que dependant de j uniquement,sera ici indice aussi en i
+c          pour un adressage plus facile en  ij  .
+c
+c
+c
+c  **************  aux points  u  et  v ,           *****************
+c      xprimu et xprimv sont respectivement les valeurs de  dx/dX
+c      yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
+c      rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
+c      cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
+c
+c  **************  aux points u, v, scalaires, et z  ****************
+c      cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
+c
+c
+c
+c         Exemple de distribution de variables sur la grille dans le
+c             domaine de travail ( X,Y ) .
+c     ................................................................
+c                  DX=DY= 1
+c
+c   
+c        +     represente  un  point scalaire ( p.exp  la pression )
+c        >     represente  la composante zonale du  vent
+c        V     represente  la composante meridienne du vent
+c        o     represente  la  vorticite
+c
+c       ----  , car aux poles , les comp.zonales covariantes sont nulles
+c
+c
+c
+c         i ->
+c
+c         1      2      3      4      5      6      7      8
+c  j
+c  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c
+c      Ci-dessus,  on voit que le nombre de pts.en longitude est egal
+c                 a   IM = 8
+c      De meme ,   le nombre d'intervalles entre les 2 poles est egal
+c                 a   JM = 4
+c
+c      Les points scalaires ( + ) correspondent donc a des valeurs
+c       entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
+c
+c      Les vents    U       ( > ) correspondent a des valeurs  semi-
+c       entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
+c
+c      Les vents    V       ( V ) correspondent a des valeurs entieres
+c       de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
+c
+c
+c
+      WRITE(6,3) 
+ 3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
+     * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
+     *  5x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux 
+     * '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
+c
+c
+      IF( nitergdiv.NE.2 ) THEN
+        gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. )
+      ELSE
+        gamdi_gdiv = 0.
+      ENDIF
+      IF( nitergrot.NE.2 ) THEN
+        gamdi_grot = coefdis/ ( float(nitergrot) -2. )
+      ELSE
+        gamdi_grot = 0.
+      ENDIF
+      IF( niterh.NE.2 ) THEN
+        gamdi_h = coefdis/ ( float(niterh) -2. )
+      ELSE
+        gamdi_h = 0.
+      ENDIF
+
+      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+     *  nitergdiv,nitergrot,niterh
+c
+      pi    = 2.* ASIN(1.)
+c
+      WRITE(6,990) 
+
+c     ----------------------------------------------------------------
+c
+      IF( .NOT.fxyhypb )   THEN
+c
+c
+       IF( ysinus )  THEN
+c
+        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+c
+c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
+
+        CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ELSE
+c
+        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+
+c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
+c
+ 
+        pxo   = clon *pi /180.
+        pyo   = 2.* clat* pi /180.
+c
+c  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
+c
+        itmax = 10
+        eps   = .1e-7
+c
+        xo1 = 0.
+        DO 10 iter = 1, itmax
+        x1  = xo1
+        f   = x1+ alphax *SIN(x1-pxo)
+        df  = 1.+ alphax *COS(x1-pxo)
+        x1  = x1 - f/df
+        xdm = ABS( x1- xo1 )
+        IF( xdm.LE.eps )GO TO 11
+        xo1 = x1
+ 10     CONTINUE
+ 11     CONTINUE
+c
+        transx = xo1
+
+        itmay = 10
+        eps   = .1e-7
+C
+        yo1  = 0.
+        DO 15 iter = 1,itmay
+        y1   = yo1
+        f    = y1 + alphay* SIN(y1-pyo)
+        df   = 1. + alphay* COS(y1-pyo)
+        y1   = y1 -f/df
+        ydm  = ABS(y1-yo1)
+        IF(ydm.LE.eps) GO TO 17
+        yo1  = y1
+ 15     CONTINUE
+c
+ 17     CONTINUE
+        transy = yo1
+
+        CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,              rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ENDIF
+c
+      ELSE
+c
+c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+c   .....................................................................
+
+      WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+ 
+       CALL fxyhyper( clat, grossismy, dzoomy, tauy    , 
+     ,                clon, grossismx, dzoomx, taux    ,
+     , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2  ,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 )
+
+  
+      ENDIF
+c
+c  -------------------------------------------------------------------
+
+c
+      rlatu(1)    =     ASIN(1.)
+      rlatu(jjp1) =  - rlatu(1)
+c
+c
+c   ....  calcul  aux  poles  ....
+c
+      yprimu(1)      = 0.
+      yprimu(jjp1)   = 0.
+c
+c
+      un4rad2 = 0.25 * rad * rad
+c
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c   -                                                                  -
+c   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
+c   -      et de   fext ,  force de coriolis  extensive  .             -
+c   -                                                                  -
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c
+c
+c
+c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+c   affectees 4 aires entourant P , calculees respectivement aux points
+c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+c
+c           ,
+c   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
+c   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
+c   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
+c   point (i,j) .
+c   On definit en outre les coefficients  alpha comme etant egaux a
+c    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
+c
+c   De meme, toute aire centree en 1 point U est egale a la somme des
+c   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
+c    Idem pour  airev, airez .
+c
+c       On a ,pour chaque maille :    dX = dY = 1
+c
+c
+c                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+c
+c
+c
+c
+c
+c   ....................................................................
+c
+c    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
+c   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
+c   taires cuij et les 4 elongat. cvij qui sont calculees aux memes 
+c     endroits  que les aireij   .    
+c
+c   ....................................................................
+c
+c     .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
+c
+c
+      DO 35 j = 1, jjp1
+c
+      IF ( j. eq. 1 )  THEN
+c
+      yprm           = yprimu1(j)
+      rlatm          = rlatu1(j)
+c
+      coslatm        = COS( rlatm )
+      radclatm       = 0.5* rad * coslatm
+c
+      DO 30 i = 1, iim
+      xprp           = xprimp025( i )
+      xprm           = xprimm025( i )
+      aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
+      aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
+      cuij2  ( i,1 ) = radclatm * xprp
+      cuij3  ( i,1 ) = radclatm * xprm
+      cvij2  ( i,1 ) = 0.5* rad * yprm
+      cvij3  ( i,1 ) = cvij2(i,1)
+  30  CONTINUE
+c
+      DO  i = 1, iim
+      aireij1( i,1 ) = 0.
+      aireij4( i,1 ) = 0.
+      cuij1  ( i,1 ) = 0.
+      cuij4  ( i,1 ) = 0.
+      cvij1  ( i,1 ) = 0.
+      cvij4  ( i,1 ) = 0.
+      ENDDO
+c
+      END IF
+c
+      IF ( j. eq. jjp1 )  THEN
+       yprp               = yprimu2(j-1)
+       rlatp              = rlatu2 (j-1)
+ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
+ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
+c
+      coslatp             = COS( rlatp )
+      radclatp            = 0.5* rad * coslatp
+c
+      DO 31 i = 1,iim
+        xprp              = xprimp025( i )
+        xprm              = xprimm025( i )
+        aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
+        aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
+        cuij1(i,jjp1)     = radclatp * xprp
+        cuij4(i,jjp1)     = radclatp * xprm
+        cvij1(i,jjp1)     = 0.5 * rad* yprp
+        cvij4(i,jjp1)     = cvij1(i,jjp1)
+ 31   CONTINUE
+c
+       DO   i    = 1, iim
+        aireij2( i,jjp1 ) = 0.
+        aireij3( i,jjp1 ) = 0.
+        cvij2  ( i,jjp1 ) = 0.
+        cvij3  ( i,jjp1 ) = 0.
+        cuij2  ( i,jjp1 ) = 0.
+        cuij3  ( i,jjp1 ) = 0.
+       ENDDO
+c
+      END IF
+c
+
+      IF ( j .gt. 1 .AND. j .lt. jjp1 )  THEN
+c
+        rlatp    = rlatu2 ( j-1 )
+        yprp     = yprimu2( j-1 )
+        rlatm    = rlatu1 (  j  )
+        yprm     = yprimu1(  j  )
+cc         rlatp    = fy    ( FLOAT(j) - 0.25 )
+cc         yprp     = fyprim( FLOAT(j) - 0.25 )
+cc         rlatm    = fy    ( FLOAT(j) + 0.25 )
+cc         yprm     = fyprim( FLOAT(j) + 0.25 )
+
+         coslatm  = COS( rlatm )
+         coslatp  = COS( rlatp )
+         radclatp = 0.5* rad * coslatp
+         radclatm = 0.5* rad * coslatm
+c
+         DO 32 i = 1,iim
+         xprp            = xprimp025( i )
+         xprm            = xprimm025( i )
+      
+         ai14            = un4rad2 * coslatp * yprp
+         ai23            = un4rad2 * coslatm * yprm
+         aireij1 ( i,j ) = ai14 * xprp
+         aireij2 ( i,j ) = ai23 * xprp
+         aireij3 ( i,j ) = ai23 * xprm
+         aireij4 ( i,j ) = ai14 * xprm
+         cuij1   ( i,j ) = radclatp * xprp
+         cuij2   ( i,j ) = radclatm * xprp
+         cuij3   ( i,j ) = radclatm * xprm
+         cuij4   ( i,j ) = radclatp * xprm
+         cvij1   ( i,j ) = 0.5* rad * yprp
+         cvij2   ( i,j ) = 0.5* rad * yprm
+         cvij3   ( i,j ) = cvij2(i,j)
+         cvij4   ( i,j ) = cvij1(i,j)
+  32     CONTINUE
+c
+      END IF
+c
+c    ........       periodicite   ............
+c
+         cvij1   (iip1,j) = cvij1   (1,j)
+         cvij2   (iip1,j) = cvij2   (1,j)
+         cvij3   (iip1,j) = cvij3   (1,j)
+         cvij4   (iip1,j) = cvij4   (1,j)
+         cuij1   (iip1,j) = cuij1   (1,j)
+         cuij2   (iip1,j) = cuij2   (1,j)
+         cuij3   (iip1,j) = cuij3   (1,j)
+         cuij4   (iip1,j) = cuij4   (1,j)
+         aireij1 (iip1,j) = aireij1 (1,j )
+         aireij2 (iip1,j) = aireij2 (1,j )
+         aireij3 (iip1,j) = aireij3 (1,j )
+         aireij4 (iip1,j) = aireij4 (1,j )
+        
+  35  CONTINUE
+c
+c    ..............................................................
+c
+      DO 37 j = 1, jjp1
+      DO 36 i = 1, iim
+      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
+     *                          aireij4(i,j)
+      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+  36  CONTINUE
+c
+c
+      aire    (iip1,j) = aire    (1,j)
+      alpha1  (iip1,j) = alpha1  (1,j)
+      alpha2  (iip1,j) = alpha2  (1,j)
+      alpha3  (iip1,j) = alpha3  (1,j)
+      alpha4  (iip1,j) = alpha4  (1,j)
+      alpha1p2(iip1,j) = alpha1p2(1,j)
+      alpha1p4(iip1,j) = alpha1p4(1,j)
+      alpha2p3(iip1,j) = alpha2p3(1,j)
+      alpha3p4(iip1,j) = alpha3p4(1,j)
+  37  CONTINUE
+c
+
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                                aireij3(i+1,j)
+      unsaire    ( i,j)= 1./ aire(i,j)
+      unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
+      unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
+      airesurg   ( i,j)= aire(i,j)/ g
+  41  CONTINUE
+      aireu     (iip1,j)  = aireu  (1,j)
+      unsaire   (iip1,j)  = unsaire(1,j)
+      unsair_gam1(iip1,j) = unsair_gam1(1,j)
+      unsair_gam2(iip1,j) = unsair_gam2(1,j)
+      airesurg   (iip1,j) = airesurg(1,j)
+  42  CONTINUE
+c
+c
+      DO 48 j = 1,jjm
+c
+        DO i=1,iim
+         airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+         DO i=1,iim
+          airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) +
+     *                           aireij4(i+1,j+1)
+          unsairez(i,j) = 1./ airez
+          unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
+          fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
+         ENDDO
+        airev     (iip1,j)  = airev(1,j)
+        unsairez  (iip1,j)  = unsairez(1,j)
+        fext      (iip1,j)  = fext(1,j)
+        unsairz_gam(iip1,j) = unsairz_gam(1,j)
+c
+  48  CONTINUE
+c
+c
+c    .....      Calcul  des elongations cu,cv, cvu     .........
+c
+      DO    j   = 1, jjm
+       DO   i  = 1, iim
+       cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
+       cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
+       cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
+       unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
+       ENDDO
+       DO   i  = 1, iim
+       cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
+       cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
+       cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
+       cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
+       cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
+       ENDDO
+       cv       (iip1,j)  = cv       (1,j)
+       cvu      (iip1,j)  = cvu      (1,j)
+       unscv2   (iip1,j)  = unscv2   (1,j)
+       cuv      (iip1,j)  = cuv      (1,j)
+       cuvsurcv (iip1,j)  = cuvsurcv (1,j)
+       cvsurcuv (iip1,j)  = cvsurcuv (1,j)
+       cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
+       cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
+       cvscuvgam(iip1,j)  = cvscuvgam(1,j)
+      ENDDO
+
+      DO  j     = 2, jjm
+        DO   i  = 1, iim
+        cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
+        unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
+        cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
+        cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
+        cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) 
+        cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    ) 
+        cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
+        ENDDO
+        cu       (iip1,j)  = cu(1,j)
+        unscu2   (iip1,j)  = unscu2(1,j)
+        cvusurcu (iip1,j)  = cvusurcu(1,j)
+        cusurcvu (iip1,j)  = cusurcvu(1,j)
+        cvuscugam1(iip1,j) = cvuscugam1(1,j)
+        cvuscugam2(iip1,j) = cvuscugam2(1,j)
+        cuscvugam (iip1,j) = cuscvugam(1,j)
+      ENDDO
+
+c
+c   ....  calcul aux  poles  ....
+c
+      DO    i      =  1, iip1
+        cu    ( i, 1 )  =   0.
+        unscu2( i, 1 )  =   0.
+        cvu   ( i, 1 )  =   0.
+c
+        cu    (i, jjp1) =   0.
+        unscu2(i, jjp1) =   0.
+        cvu   (i, jjp1) =   0.
+      ENDDO
+c
+c    ..............................................................
+c
+      DO j = 1, jjm
+        DO i= 1, iim
+         airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
+         aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
+        ENDDO
+         airvscu2  (iip1,j)  = airvscu2(1,j)
+         aivscu2gam(iip1,j)  = aivscu2gam(1,j)
+      ENDDO
+
+      DO j=2,jjm
+        DO i=1,iim
+         airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
+         aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot ) 
+        ENDDO
+         airuscv2  (iip1,j)  = airuscv2  (1,j)
+         aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
+      ENDDO
+
+c
+c   calcul des aires aux  poles :
+c   -----------------------------
+c
+      apoln       = SSUM(iim,aire(1,1),1)
+      apols       = SSUM(iim,aire(1,jjp1),1)
+      unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
+      unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
+      unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
+      unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
+c
+c-----------------------------------------------------------------------
+c     gtitre='Coriolis version ancienne'
+c     gfichier='fext1'
+c     CALL writestd(fext,iip1*jjm)
+c
+c   changement F. Hourdin calcul conservatif pour fext
+c   constang contient le produit a * cos ( latitude ) * omega
+c
+      DO i=1,iim
+         constang(i,1) = 0.
+      ENDDO
+      DO j=1,jjm-1
+        DO i=1,iim
+         constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
+        ENDDO
+      ENDDO
+      DO i=1,iim
+         constang(i,jjp1) = 0.
+      ENDDO
+c
+c   periodicite en longitude
+c
+      DO j=1,jjm
+        fext(iip1,j)     = fext(1,j)
+      ENDDO
+      DO j=1,jjp1
+        constang(iip1,j) = constang(1,j)
+      ENDDO
+
+c fin du changement
+
+c
+c-----------------------------------------------------------------------
+c
+       WRITE(6,*) '   ***  Coordonnees de la grille  *** '
+       WRITE(6,995)
+c
+       WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,iip1
+         rlonvv(i) = rlonv(i)*180./pi
+        ENDDO
+       WRITE(6,400) rlonvv
+c
+       WRITE(6,995)
+       WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjm
+         rlatuu(i)=rlatv(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjm)
+c
+        DO i=1,iip1
+          rlonvv(i)=rlonu(i)*180./pi
+        ENDDO
+       WRITE(6,995)
+       WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
+       WRITE(6,995)
+       WRITE(6,400) rlonvv
+       WRITE(6,995)
+
+       WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjp1
+         rlatuu(i)=rlatu(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjp1)
+       WRITE(6,995)
+c
+444    format(f10.3,f6.0)
+400    FORMAT(1x,8f8.2)
+990    FORMAT(//)
+995    FORMAT(/)
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inigrads.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inigrads.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inigrads.F	(revision 984)
@@ -0,0 +1,92 @@
+!
+! $Header$
+!
+      subroutine inigrads(if,im
+     s  ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz
+     s  ,dt,file,titlel)
+
+
+      implicit none
+
+      integer if,im,jm,lm,i,j,l,lnblnk
+      real x(im),y(jm),z(lm),fx,fy,fz,dt
+      real xmin,xmax,ymin,ymax
+
+      character file*10,titlel*40
+
+#include "gradsdef.h"
+
+c     data unit/66,32,34,36,38,40,42,44,46,48/
+      integer nf
+      save nf
+      data nf/0/
+
+      unit(1)=66
+      unit(2)=32
+      unit(3)=34
+      unit(4)=36
+      unit(5)=38
+      unit(6)=40
+      unit(7)=42
+      unit(8)=44
+      unit(9)=46
+
+      if (if.le.nf) stop'verifier les appels a inigrads'
+
+      print*,'Entree dans inigrads'
+
+      nf=if
+      title(if)=titlel
+      ivar(if)=0
+
+      fichier(if)=file(1:lnblnk(file))
+
+      firsttime(if)=.true.
+      dtime(if)=dt
+
+      iid(if)=1
+      ifd(if)=im
+      imd(if)=im
+      do i=1,im
+         xd(i,if)=x(i)*fx
+         if(xd(i,if).lt.xmin) iid(if)=i+1
+         if(xd(i,if).le.xmax) ifd(if)=i
+      enddo
+      print*,'On stoke du point ',iid(if),'  a ',ifd(if),' en x'
+
+      jid(if)=1
+      jfd(if)=jm
+      jmd(if)=jm
+      do j=1,jm
+         yd(j,if)=y(j)*fy
+         if(yd(j,if).gt.ymax) jid(if)=j+1
+         if(yd(j,if).ge.ymin) jfd(if)=j
+      enddo
+      print*,'On stoke du point ',jid(if),'  a ',jfd(if),' en y'
+
+      print*,'Open de dat'
+      print*,'file=',file
+      print*,'fichier(if)=',fichier(if)
+
+      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
+      print*,file(1:lnblnk(file))//'.dat'
+
+      OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat'
+     s   ,FORM='unformatted',
+     s   ACCESS='direct'
+     s  ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1))
+
+      print*,'Open de dat ok'
+
+      lmd(if)=lm
+      do l=1,lm
+         zd(l,if)=z(l)*fz
+      enddo
+
+      irec(if)=0
+
+      print*,if,imd(if),jmd(if),lmd(if)
+      print*,'if,imd(if),jmd(if),lmd(if)'
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniprint.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniprint.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/iniprint.h	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/initdynav_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/initdynav_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/initdynav_p.F	(revision 984)
@@ -0,0 +1,176 @@
+!
+! $Header$
+!
+c
+c
+      subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt
+     .                     ,nq,fileid)
+
+       USE IOIPSL
+       use parallel
+       use Write_field
+       use misc_mod
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL. Initialisation du fichier histoire moyenne.
+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 : frequence d'ecriture
+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   Sortie:
+C      fileid: ID du fichier netcdf cree
+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 "advtrac.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid
+      integer nq
+      integer thoriid, zvertiid
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer ii,jj
+      integer zan, dayref
+      integer :: jjb,jje,jjn
+      
+      if (adjust) return
+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
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj)  = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+             
+      call histbeg(trim(infile)//'_'//trim(int2str(mpi_rank))//'.nc',
+     .             iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,
+     .             tau0, zjulian, tstep, thoriid, fileid)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sigss', 'Niveaux sigma','Pa',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      write(6,*)'inithistave',tstep
+      call histdef(fileid, 'u', 'vents u scalaires moyennes',
+     .             'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(fileid, 'v', 'vents v scalaires moyennes',
+     .             'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(fileid, 'temp', 'temperature moyennee', 'K',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel moyenne', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histdef(fileid, ttext(iq), ttext(iq), '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/initfluxsto_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/initfluxsto_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/initfluxsto_p.F	(revision 984)
@@ -0,0 +1,255 @@
+!
+! $Header$
+!
+      subroutine initfluxsto_p
+     .  (infile,tstep,t_ops,t_wrt,nq,
+     .                    fileid,filevid,filedid)
+
+       USE IOIPSL
+       use parallel
+       use Write_field
+       use misc_mod
+       
+      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   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"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 itau
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+      integer nq,ndex(1)
+      real nivd(1)
+
+C   Variables locales
+C
+      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
+      integer :: jjb,jje,jjn
+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
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+       
+      call histbeg(trim(infile)//'_'//trim(int2str(mpi_rank))//'.nc',
+     .             iip1, rlong(:,1), jjp1, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,
+     .             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
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jje=jj_end-1
+      if (pole_sud) jjn=jj_nb-1
+
+      call histbeg('fluxstokev_'//trim(int2str(mpi_rank))//'.nc',
+     .             iip1, rlong(:,1), jjm, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+	
+      rl(1,1) = 1.	
+      
+      if (mpi_rank==0) then
+          
+        call histbeg('defstoke.nc', 1, rl, 1, rl,
+     .               1, 1, 1, 1,
+     .               tau0, zjulian, tstep, dhoriid, filedid)
+     
+      endif
+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
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+      call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje),
+     .             'scalar','Grille points scalaires', thoriid)
+	
+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,jjn,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iip1,jjn,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+        if (mpi_rank==0) then
+	
+	CALL histdef(filedid, "dtvr", "tps dyn", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+        
+         CALL histdef(filedid, "istdyn", "tps stock", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         
+         CALL histdef(filedid, "istphy", "tps stock phy", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+        endif
+C
+C Masse 
+C
+      call histdef(fileid, 'masse', 'Masse', 'kg',
+     .             iip1, jjn, 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, jjn, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Pbarv 
+C
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
+     .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  w 
+C
+      if (pole_sud) jjn=jj_nb
+      call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C Geopotentiel 
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjn, 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
+	
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inithist_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inithist_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inithist_p.F	(revision 984)
@@ -0,0 +1,214 @@
+!
+! $Header$
+!
+      subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt,nq,
+     .                      fileid,filevid)
+
+       USE IOIPSL
+       use parallel
+       use Write_field
+       use misc_mod
+
+      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   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 "advtrac.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq
+
+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
+      integer :: jjb,jje,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+       
+      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
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+      
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      
+       call histbeg(trim(infile)//'_'//trim(int2str(mpi_rank))//'.nc',
+     .             iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,
+     .             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
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      if (pole_sud) jje=jj_end-1
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histbeg('dyn_histv_'//trim(int2str(mpi_rank))//'.nc', 
+     .             iip1, rlong(:,1), jjn, rlat(1,jjb:jje),
+     .             1, iip1, 1, jjn,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+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
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+
+      call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje),
+     .              'scalar','Grille points scalaires', thoriid)
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      jjn=jj_nb
+
+      call histdef(fileid, 'ucov', 'vents u covariants', 'm/s',
+     .             iip1, jjn, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histdef(filevid, 'vcov', 'vents v covariants', 'm/s',
+     .             iip1, jjn, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      jjn=jj_nb
+      
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histdef(fileid, ttext(iq),  ttext(iq), '-',
+     .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        enddo
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjn, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/initial0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/initial0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/initial0.F	(revision 984)
@@ -0,0 +1,12 @@
+!
+! $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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/integrd_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/integrd_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/integrd_p.F	(revision 984)
@@ -0,0 +1,337 @@
+!
+! $Header$
+!
+      SUBROUTINE integrd_p
+     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
+     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold)
+      USE parallel
+      IMPLICIT NONE
+
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Incrementation des tendances dynamiques
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "logic.h"
+#include "temps.h"
+#include "serre.h"
+#include "advtrac.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nq
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nq)
+      REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
+
+      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
+
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
+      REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
+      REAL,SAVE :: p(ip1jmp1,llmp1)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+      REAL deltap( ip1jmp1,llm )
+
+      INTEGER  l,ij,iq
+
+      REAL SSUM
+      EXTERNAL SSUM
+      INTEGER ijb,ije,jjb,jje
+      REAL,SAVE :: ps(ip1jmp1)
+c-----------------------------------------------------------------------
+     
+      if (pole_nord) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO  l = 1,llm
+          DO  ij = 1,iip1
+           ucov(    ij    , l) = 0.
+           uscr(     ij      ) = 0.
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT        
+      ENDIF
+
+      if (pole_sud) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO  l = 1,llm
+          DO  ij = 1,iip1
+           ucov( ij +ip1jm, l) = 0.
+           uscr( ij +ip1jm   ) = 0.
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT      
+      ENDIF
+
+c    ............    integration  de       ps         ..............
+
+c      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO  l = 1,llm
+        massescr(ijb:ije,l)=masse(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT 
+
+c$OMP MASTER      
+      DO 2 ij = ijb,ije
+       pscr (ij)    = ps0(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)
+   2  CONTINUE
+c
+      DO ij = ijb,ije
+        IF( ps(ij).LT.0. ) THEN
+         PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij)
+         STOP' dans integrd'
+        ENDIF
+      ENDDO
+c
+      if (pole_nord) THEN
+      
+        DO  ij    = 1, iim
+         tppn(ij) = aire(   ij   ) * ps(  ij    )
+        ENDDO
+         tpn      = SSUM(iim,tppn,1)/apoln
+        DO ij   = 1, iip1
+         ps(   ij   )  = tpn
+        ENDDO
+      
+      ENDIF
+      
+      if (pole_sud) THEN
+      
+        DO  ij    = 1, iim
+         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+        ENDDO
+         tps      = SSUM(iim,tpps,1)/apols
+        DO ij   = 1, iip1
+         ps(ij+ip1jm)  = tps
+        ENDDO
+      
+      ENDIF
+c$OMP END MASTER
+c$OMP BARRIER
+c
+c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+c
+
+      CALL pression_p ( ip1jmp1, ap, bp, ps, p )
+c$OMP BARRIER
+      CALL massdair_p (     p  , masse         )
+
+c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO  l = 1,llm
+        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+      jjb=jj_begin
+      jje=jj_end
+      CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1  )
+c
+
+c    ............   integration  de  ucov, vcov,  h     ..............
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO 10 l = 1,llm
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4 ij = ijb,ije
+      uscr( ij )   =  ucov( ij,l )
+      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+   4  CONTINUE
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 5 ij = ijb,ije
+      vscr( ij )   =  vcov( ij,l )
+      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+   5  CONTINUE
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO 6 ij = ijb,ije
+      hscr( ij )    =  teta(ij,l)
+      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) 
+     $                + dt * dteta(ij,l) / masse(ij,l)
+   6  CONTINUE
+
+c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
+      IF (pole_nord) THEN
+       
+        DO  ij   = 1, iim
+          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+        ENDDO
+          tpn      = SSUM(iim,tppn,1)/apoln
+
+        DO ij   = 1, iip1
+          teta(   ij   ,l)  = tpn
+        ENDDO
+      
+      ENDIF
+      
+      IF (pole_sud) THEN
+       
+        DO  ij   = 1, iim
+          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+        ENDDO
+          tps      = SSUM(iim,tpps,1)/apols
+
+        DO ij   = 1, iip1
+          teta(ij+ip1jm,l)  = tps
+        ENDDO
+      
+      ENDIF
+c
+
+      IF(leapf)  THEN
+c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+        ijb=ij_begin
+        ije=ij_end
+        ucovm1(ijb:ije,l)=uscr(ijb:ije)
+        tetam1(ijb:ije,l)=hscr(ijb:ije)
+        if (pole_sud) ije=ij_end-iip1
+        vcovm1(ijb:ije,l)=vscr(ijb:ije)
+      
+      END IF
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+
+c
+c   .......  integration de   q   ......
+c
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP MASTER
+         DO l = 1, llm
+          DO ij = ijb, ije
+           deltap(ij,l) =  p(ij,l) - p(ij,l+1) 
+          ENDDO
+         ENDDO
+
+         CALL qminimum_p( q, nq, deltap )
+c
+c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+c
+
+      IF (pole_nord) THEN 
+      
+        DO iq = 1, nq
+          DO l = 1, llm
+  
+             DO ij = 1, iim
+               qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+             ENDDO
+               qpn  =  SSUM(iim,qppn,1)/apoln
+      
+             DO ij = 1, iip1
+               q(   ij   ,l,iq)  = qpn
+             ENDDO    
+  
+          ENDDO
+        ENDDO
+      
+      ENDIF
+
+      IF (pole_sud) THEN 
+      
+        DO iq = 1, nq
+          DO l = 1, llm
+  
+             DO ij = 1, iim
+               qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+             ENDDO
+               qps  =  SSUM(iim,qpps,1)/apols 
+  
+             DO ij = 1, iip1
+               q(ij+ip1jm,l,iq)  = qps
+             ENDDO    
+  
+          ENDDO
+        ENDDO
+      
+      ENDIF
+      
+c$OMP END MASTER
+c$OMP BARRIER
+
+c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm      
+        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)        
+      ENDDO
+c$OMP END DO NOWAIT
+c
+c
+c     .....   FIN  de l'integration  de   q    .......
+
+15    continue
+
+c$OMP MASTER
+        ps0(ijb:ije)=ps(ijb:ije)
+c$OMP END MASTER
+c    .................................................................
+
+
+      IF( leapf )  THEN
+c       CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+c       CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+c$OMP MASTER
+        psm1(ijb:ije)=pscr(ijb:ije)
+c$OMP END MASTER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l = 1, llm
+            massem1(ijb:ije,l)=massescr(ijb:ije,l)
+	  ENDDO
+c$OMP END DO NOWAIT	  
+      END IF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_barx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_barx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_barx.F	(revision 984)
@@ -0,0 +1,218 @@
+!
+! $Header$
+!
+       SUBROUTINE inter_barx ( idatmax,xidat,fdat,imodmax,ximod,fmod ) 
+
+c      .... Auteurs :  Robert Sadourny ,  P. Le Van  .....
+c
+       IMPLICIT NONE
+c    ----------------------------------------------------------
+c        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
+c            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
+c    ----------------------------------------------------------
+c
+c     idat : indice du champ de donnees, de 1 a idatmax
+c     imod : indice du champ du modele,  de 1 a  imodmax
+c     fdat(idat) : champ de donnees (entrees)
+c     fmod(imod) : champ du modele (sorties)
+c     xidat(idat): abscisses des interfaces des mailles donnees
+c     ximod(imod): abscisses des interfaces des mailles modele
+c      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
+c      ( Les abscisses sont exprimes en degres)
+
+
+      INTEGER idatmax, imodmax
+      REAL xidat(idatmax),fdat(idatmax),ximod(imodmax),fmod(imodmax)
+
+c    ...  Variables locales ... 
+    
+      REAL xxid(idatmax+1), xxd(idatmax+1), fdd(idatmax+1)
+      REAL  fxd(idatmax+1), xchan(idatmax+1), fdchan(idatmax+1) 
+      REAL  xxim(imodmax)
+
+      REAL x0,xim0,dx,dxm
+      REAL chmin,chmax,pi
+
+      INTEGER imod,idat,i,ichang,id0,id1,nid,idatmax1
+      
+      pi = 2. * ASIN(1.)
+
+c  -----------------------------------------------------
+c   REDEFINITION DE L'ORIGINE DES ABSCISSES
+c    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
+c  -----------------------------------------------------
+      DO imod = 1,imodmax
+       xxim(imod) = ximod(imod)
+      ENDDO
+
+      CALL minmax( imodmax,xxim,chmin,chmax)
+       IF( chmax.LT.6.50 )   THEN
+c        PRINT  3
+c        PRINT *,'   conversion des longit. ximod (donnees en radians)'
+c     , ,' en degres  .' 
+c        PRINT  3
+        DO imod = 1, imodmax
+        xxim(imod) = xxim(imod) * 180./pi
+        ENDDO  
+       ENDIF
+
+      xim0 = xxim(imodmax) - 360.
+
+      DO imod = 1, imodmax
+       xxim(imod) = xxim(imod) - xim0
+      ENDDO
+
+      idatmax1 = idatmax +1
+
+      DO idat = 1, idatmax
+       xxd(idat) = xidat(idat)
+      ENDDO
+
+      CALL minmax( idatmax,xxd,chmin,chmax)
+       IF( chmax.LT.6.50 )  THEN
+c        PRINT  3
+c        PRINT *,'   conversion des longit. ximod (donnees en radians)'
+c     , ,' en degres  .' 
+c        PRINT  3
+        DO idat = 1, idatmax
+        xxd(idat) = xxd(idat) * 180./pi
+        ENDDO  
+       ENDIF
+
+      DO idat = 1, idatmax
+       xxd(idat) = AMOD( xxd(idat) - xim0, 360. )
+       fdd(idat) = fdat (idat)
+      ENDDO
+c       PRINT *,' xxd redef. origine abscisses '
+c       PRINT 2,(xxd(i),i=1,idatmax)
+
+      DO i = 2, idatmax
+        IF( ( xxd(i) - xxd(i-1)).LT.0. )  THEN
+         ichang = i
+         GO TO 5
+        ENDIF
+      ENDDO
+      GO TO 6
+c
+c  ***  reorganisation  des longitudes entre 0. et 360. degres ****
+c
+ 5    nid = idatmax - ichang +1
+      DO i = 1, nid
+        xchan (i) = xxd(i+ichang -1 )
+        fdchan(i) = fdd(i+ichang -1 )
+      ENDDO
+       DO i=1,ichang -1
+        xchan (i+ nid) = xxd(i)
+        fdchan(i+nid) = fdd(i) 
+       ENDDO
+      DO i =1,idatmax
+       xxd(i) = xchan(i)
+       fdd(i) = fdchan(i)
+      ENDDO
+
+ 6    continue
+
+
+c  ------------------------------------------------
+c    translation des champs de donnees par rapport
+c    a la nouvelle origine, avec redondance de la
+c       maille a cheval sur les bords
+c -----------------------------------------------
+
+      id0 = 0
+      id1 = 0
+
+      DO idat = 1, idatmax
+       IF ( xxd( idatmax1- idat ).LT.360.)   GO TO 10
+       id1 = id1 + 1
+      ENDDO
+
+ 10   DO idat = 1, idatmax
+       IF (xxd(idat).GT.0.) GO TO 20
+       id0 = id0 + 1
+      END DO
+
+ 20   IF( id1.EQ.0 ) GO TO 30
+      DO idat = 1, id1
+       xxid(idat) = xxd(idatmax - id1 + idat) - 360.
+       fxd (idat) = fdd(idatmax - id1 + idat)     
+      END DO
+      DO idat = 1, idatmax - id1
+       xxid(idat + id1) = xxd(idat)
+       fxd (idat + id1) = fdd(idat)
+      END DO
+
+  30  IF(id0.EQ.0) GO TO 40
+      DO idat = 1, idatmax - id0
+       xxid(idat) = xxd(idat + id0)
+       fxd (idat) = fdd(idat + id0)
+      END DO
+
+      DO idat = 1, id0
+       xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
+       fxd  (idatmax - id0 + idat) =  fdd(idat)   
+      END DO
+      GO TO 50
+ 
+ 40   DO idat = 1, idatmax
+       xxid(idat)  = xxd(idat)
+       fxd (idat)  = fdd(idat)
+      ENDDO
+
+ 50   xxid(idatmax1) = xxid(1) + 360.
+      fxd (idatmax1) = fxd(1)
+
+c  ------------------------------------
+c   initialisation du champ du modele
+
+      DO imod = 1, imodmax
+       fmod(imod) = 0.
+      END DO
+ 
+c      PRINT *,' id0 id1 ',id0,id1
+c      PRINT *,' xxim apres translation  '
+c      PRINT 2,(xxim(i),i=1,imodmax)
+c      PRINT *,' xxid apres translation '
+c      PRINT 2,(xxid(i),i=1,idatmax)
+c ---------------------------------------
+c iteration
+
+      x0   = xim0
+      dxm  = 0.
+      imod = 1
+      idat = 1
+ 
+ 100  IF (xxim(imod).LT.xxid(idat)) THEN
+       dx   = xxim(imod) - x0
+       dxm  = dxm + dx
+       fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm
+       x0   = xxim(imod)
+       dxm  = 0.
+       imod = imod + 1
+       IF (imod.LE.imodmax) GO TO 100
+  
+      ELSE IF (xxim(imod).GT.xxid(idat)) THEN
+       dx   = xxid(idat) - x0
+       dxm  = dxm + dx
+       fmod(imod) = fmod(imod) + dx * fxd(idat)
+       x0   = xxid(idat)
+       idat = idat + 1
+       GO TO 100
+ 
+      ELSE
+       dx   = xxim(imod) - x0
+       dxm  = dxm + dx
+       fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm
+       x0   = xxim(imod)
+       dxm  = 0.
+       imod = imod + 1
+       idat = idat + 1
+       IF (imod.LE.imodmax) GO TO 100
+      END IF
+     
+
+3      FORMAT(1x,70(1h-))
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_barxy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_barxy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_barxy.F	(revision 984)
@@ -0,0 +1,59 @@
+!
+! $Header$
+!
+       SUBROUTINE inter_barxy ( interfd,jnterfd,dlonid,dlatid ,
+     ,        champ,imod,jmod,rlonimod,rlatimod, jsort,champint )
+
+c    Auteur :   P. Le Van
+c
+       INTEGER interfd,jnterfd,imod,jmod
+       REAL champ(interfd,jnterfd +1 ),dlonid(interfd),dlatid(jnterfd),
+     ,      champint(imod,jsort)
+       REAL rlonimod(imod),rlatimod(jmod)
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+       REAL champx(imod),champy(jnterfd +1,imod),chpn(imod),chps(imod)
+       REAL chhpn,chhps
+       REAL fmody(jjp1)
+c
+
+       DO j = 1, jnterfd + 1
+        CALL inter_barx( interfd, dlonid, champ( 1,j ),
+     ,                       imod, rlonimod , champx )
+         DO i = 1,imod
+           champy(j,i) = champx(i)
+         ENDDO
+       ENDDO
+
+       DO i = 1, imod
+        CALL inter_bary( jjm,jnterfd,dlatid,champy(1,i),
+     ,                     jmod ,rlatimod,  fmody     )
+          DO j = 1, jsort
+           champint(i,j) = fmody(j)
+          ENDDO
+       ENDDO
+
+       IF( jsort.EQ.jjp1)  THEN
+
+c   ....  Valeurs uniques  aux  poles ....
+c
+         DO i =  1,imod
+          chpn(i)  = aire( i,  1   ) * champint( i, 1   )
+          chps(i)  = aire( i, jjp1 ) * champint( i,jjp1 )
+         ENDDO
+          chhpn  = SSUM(imod,chpn,1)/apoln
+          chhps  = SSUM(imod,chps,1)/apols
+
+         DO i = 1, imod
+          champint( i,  1  ) = chhpn
+          champint( i, jjp1) = chhps
+         ENDDO
+c
+       ENDIF
+
+       RETURN
+       END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_bary.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_bary.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/inter_bary.F	(revision 984)
@@ -0,0 +1,135 @@
+!
+! $Header$
+!
+       SUBROUTINE inter_bary( jjm, jdatmax, yjdatt, fdatt  ,
+     ,                       jmodmax, yjmodd,  fmod      )
+c
+c    ...  Auteurs :  Robert Sadourny  , P. Le Van ...
+c
+       IMPLICIT NONE
+
+c  ----------------------------------------------------------
+c       INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES  .
+c         VERSION UNIDIMENSIONNELLE  ,    EN LATITUDE  .
+c  ----------------------------------------------------------
+c
+c     jdat : indice du champ de donnees, de 1 a jdatmax
+c     jmod : indice du champ du modele,  de 1 a jmodmax
+c     fdatt(jdatmax) : champ de donnees (entrees)
+c     yjdatt(jdatmax): ordonnees des interfaces des mailles donnees
+c     yjmodd(jmodmax): ordonnees des interfaces des mailles modele
+c     fmod(jmodmax)  : champ du modele  (sorties)
+c
+c      ( L'indice 1 correspond a l'interface maille 1 / maille 2)
+c      ( Les ordonnees sont exprimees en degres)
+c
+c     jdatmax = nb. d'interfaces  donnees =  nombre de donnees - 1 
+c     jmodmax = nb. d'interfaces  modele
+
+c     Si jmodmax = jjm , on veut interpoler sur les jjm+1 latitudes 
+c       rlatu   du modele ( lat.  des scalaires et de U ) 
+c
+c     Si jmodmax = jjp1 , on veut interpoler sur les jjm latitudes 
+c       rlatv du modele  ( lat.  de  V ) 
+
+c  ....  Arguments  en entree  .......
+
+       INTEGER jjm , jdatmax, jmodmax
+       REAL    yjdatt( jdatmax ) , fdatt( jdatmax +1 )
+       REAL    yjmodd( jmodmax )     
+
+c  ....  Arguments  en sortie  .......
+c
+       REAL    fmod( jmodmax + 1 )
+c
+c   ...... Variables locales  ......
+
+       INTEGER      jmods
+
+       REAL       yjdat ( jdatmax +1 ), fdat( jdatmax +1) 
+       REAL       fscrat( jdatmax +1 )
+       REAL       yjmod ( jmodmax +1 )
+       LOGICAL    decrois
+       SAVE       decrois
+c
+       REAL y0,dy,dym 
+       INTEGER jdat, jmod,i
+c
+
+        DO i = 1, jdatmax +1
+         fdat (i) = fdatt (i)
+        ENDDO
+
+       CALL ord_coord (  jdatmax , yjdatt(1), yjdat(1), decrois ) 
+
+       IF( decrois )   THEN
+         DO i = 1,jdatmax + 1
+          fscrat(i) = fdat(i)
+         ENDDO
+         DO i = 1, jdatmax + 1
+          fdat(i) = fscrat( jdatmax + 2 -i )
+         ENDDO
+
+       ENDIF
+
+       CALL ord_coordm (jmodmax,yjmodd(1),yjmod(1),jjm,jmods,decrois ) 
+c
+c      Initialisation des variables
+c    --------------------------------
+
+       DO jmod = 1, jmods
+        fmod(jmod) = 0.
+       END DO
+
+       y0    = 0.
+       dym   = 0.
+       jmod  = 1
+       jdat  = 1
+c  --------------------
+c      Iteration
+c  --------------------
+
+100    IF ( yjmod(jmod).LT.yjdat(jdat) ) THEN
+        dy         = yjmod(jmod) - y0
+        dym        = dym + dy
+        fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym
+        y0         = yjmod(jmod)
+        dym        = 0.
+        jmod       = jmod + 1
+        GO TO 100
+
+       ELSE IF ( yjmod(jmod).GT.yjdat(jdat) ) THEN
+        dy         = yjdat(jdat) - y0
+        dym        = dym + dy
+        fmod(jmod) = fmod(jmod) + dy * fdat(jdat)
+        y0         = yjdat(jdat)
+        jdat       = jdat + 1
+
+       GO TO 100
+
+       ELSE
+        dy         = yjmod(jmod) - y0
+        dym        = dym + dy
+        fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym
+        y0         = yjmod(jmod)
+        dym        = 0.
+        jmod       = jmod + 1
+        jdat       = jdat + 1
+
+        IF ( jmod.LE.jmods ) GO TO 100
+       END IF
+c   ---------------------------------------------
+c    Le test de fin suppose que l'interface 0
+c    est commune aux deux grilles yjdat et yjmod.
+c   ----------------------------------------------
+       IF( decrois )  THEN
+         DO i = 1,jmods
+          fscrat(i) = fmod(i)
+         ENDDO
+         DO i = 1, jmods
+          fmod(i) = fscrat( jmods + 1 -i )
+         ENDDO
+       ENDIF
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/interpost.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/interpost.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/interpost.F	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+        subroutine interpost(q,qppm)
+
+       implicit none
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c Arguments   
+      real   q(iip1,jjp1,llm)
+      real   qppm(iim,jjp1,llm)
+c Local
+      integer l,i,j
+  
+c RE-INVERSION DES NIVEAUX
+c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+c On passe donc des niveaux de Lin à ceux du LMDZ
+           
+        do l=1,llm
+          do j=1,jjp1
+             do i=1,iim
+                 q(i,j,l)=qppm(i,j,llm-l+1)
+             enddo
+          enddo
+         enddo
+            
+c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D
+
+         do l=1,llm
+           do j=1,jjp1
+            q(iip1,j,l)=q(1,j,l)
+           enddo
+         enddo
+  
+      
+       return
+
+       end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/interpre.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/interpre.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/interpre.F	(revision 984)
@@ -0,0 +1,132 @@
+!
+! $Header$
+!
+       subroutine interpre(q,qppm,w,fluxwppm,masse,
+     s            apppm,bpppm,massebx,masseby,pbaru,pbarv,
+     s            unatppm,vnatppm,psppm)
+
+       implicit none
+
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+c---------------------------------------------------
+c Arguments     
+      real   apppm(llm+1),bpppm(llm+1)
+      real   q(iip1,jjp1,llm),qppm(iim,jjp1,llm)
+c---------------------------------------------------
+      real   masse(iip1,jjp1,llm) 
+      real   massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)      
+      real   w(iip1,jjp1,llm+1)
+      real   fluxwppm(iim,jjp1,llm)
+      real   pbaru(iip1,jjp1,llm )
+      real   pbarv(iip1,jjm,llm)
+      real   unatppm(iim,jjp1,llm)
+      real   vnatppm(iim,jjp1,llm)
+      real   psppm(iim,jjp1)
+c---------------------------------------------------
+c Local
+      real   vnat(iip1,jjp1,llm)
+      real   unat(iip1,jjp1,llm)
+      real   fluxw(iip1,jjp1,llm)
+      real   smass(iip1,jjp1)
+c----------------------------------------------------
+      integer l,ij,i,j
+
+c       CALCUL DE LA PRESSION DE SURFACE
+c       Les coefficients ap et bp sont passés en common 
+c       Calcul de la pression au sol en mb optimisée pour 
+c       la vectorialisation
+                   
+         do j=1,jjp1
+             do i=1,iip1
+                smass(i,j)=0.
+             enddo
+         enddo
+
+         do l=1,llm
+             do j=1,jjp1
+                 do i=1,iip1
+                    smass(i,j)=smass(i,j)+masse(i,j,l)
+                 enddo
+             enddo
+         enddo
+      
+         do j=1,jjp1
+             do i=1,iim
+                 psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01
+             end do
+         end do                        
+       
+c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS
+c Le programme ppm3d travaille avec les composantes
+c de vitesse et pas les flux, on doit donc passer de l'un à l'autre
+c Dans le même temps, on fait le changement d'orientation du vent en v
+      do l=1,llm
+          do j=1,jjm
+              do i=1,iip1
+                  vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)             
+              enddo
+          enddo
+          do  i=1,iim
+          vnat(i,jjp1,l)=0.
+          enddo
+          do j=1,jjp1
+              do i=1,iip1
+                  unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)
+              enddo
+          enddo
+      enddo
+              
+c CALCUL DU FLUX MASSIQUE VERTICAL
+c Flux en l=1 (sol) nul
+      fluxw=0.        
+      do l=1,llm
+           do j=1,jjp1
+              do i=1,iip1              
+               fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j)
+C               print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l),
+C     c                      'w(i,j,l)=',w(i,j,l)
+              enddo
+           enddo
+      enddo
+      
+c INVERSION DES NIVEAUX
+c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport
+c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface
+c On passe donc des niveaux du LMDZ à ceux de Lin
+     
+      do l=1,llm+1
+          apppm(l)=ap(llm+2-l)
+          bpppm(l)=bp(llm+2-l)         
+      enddo 
+     
+      do l=1,llm
+          do j=1,jjp1
+             do i=1,iim     
+                 unatppm(i,j,l)=unat(i,j,llm-l+1)
+                 vnatppm(i,j,l)=vnat(i,j,llm-l+1)
+                 fluxwppm(i,j,l)=fluxw(i,j,llm-l+1)
+                 qppm(i,j,l)=q(i,j,llm-l+1)                              
+             enddo
+          enddo                                
+      enddo
+   
+      return
+      end
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ismax.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ismax.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ismax.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ismin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ismin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ismin.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/juldate.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/juldate.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/juldate.F	(revision 984)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+	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 real (a-h,o-z)
+	frac=((os/60.+om)/60.+oh)/24.
+	ojou=dfloat(ijou)+frac
+	    year=dfloat(ian)
+	    rmon=dfloat(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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien.F	(revision 984)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien ( klevel, teta, divgra )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c    ....     calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .........      variables  en arguments   ..............
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    .......................................................
+
+
+c
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+      CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_gam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_gam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_gam.F	(revision 984)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam ,
+     *                        unsapolnga, unsapolsga, teta, divgra )
+
+c  P. Le Van
+c
+c   ************************************************************
+c
+c      ....   calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c    klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    ............     variables  en arguments    ..........
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
+     *     unsapolnga, unsapolsga
+c
+c    ...........    variables  locales    .................
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    ......................................................
+
+c
+c
+c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+c
+      CALL   grad ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_gam_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_gam_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_gam_p.F	(revision 984)
@@ -0,0 +1,65 @@
+      SUBROUTINE laplacien_gam_p ( klevel, cuvsga, cvusga, unsaigam ,
+     *                        unsapolnga, unsapolsga, teta, divgra )
+
+c  P. Le Van
+c
+c   ************************************************************
+c
+c      ....   calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c    klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    ............     variables  en arguments    ..........
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
+     *     unsapolnga, unsapolsga
+c
+c    ...........    variables  locales    .................
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    ......................................................
+
+      INTEGER :: ijb,ije
+      INTEGER :: l      
+c
+c
+c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+
+c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+      
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud ) ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,klevel      
+        divgra(ijb:ije,l)=teta(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c
+      CALL   grad_p ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam_p ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_p.F	(revision 984)
@@ -0,0 +1,56 @@
+      SUBROUTINE laplacien_p ( klevel, teta, divgra )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c    ....     calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .........      variables  en arguments   ..............
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      INTEGER :: l
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    .......................................................
+
+      
+      INTEGER :: ijb,ije,jjb,jje
+c
+c      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud ) ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,klevel      
+        divgra(ijb:ije,l)=teta(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      jjb=jj_begin-1
+      jje=jj_end+1
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud ) jje=jj_end
+      
+      CALL filtreg_p( divgra,jjb,jje,jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad_p ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf_p ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rot.F	(revision 984)
@@ -0,0 +1,39 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
+c
+c    P. Le Van
+c
+c   ************************************************************
+c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+c   ************************************************************
+c
+c     klevel et rotin  sont des arguments  d'entree pour le s-prog
+c      rotout           est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c 
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+c   ........................................................
+c
+c
+      CALL  filtreg ( rotin ,   jjm, klevel,   2, 1, .FALSE., 1 )
+
+      CALL   nxgrad ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rot_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rot_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rot_p.F	(revision 984)
@@ -0,0 +1,45 @@
+      SUBROUTINE laplacien_rot_p ( klevel, rotin, rotout,ghx,ghy )
+c
+c    P. Le Van
+c
+c   ************************************************************
+c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+c   ************************************************************
+c
+c     klevel et rotin  sont des arguments  d'entree pour le s-prog
+c      rotout           est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c 
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+c   ........................................................
+c
+c
+      INTEGER :: ijb,ije,jjb,jje
+      
+      jjb=jj_begin-1
+      jje=jj_end+1
+      
+      if (pole_nord) jjb=jj_begin
+      if (pole_sud) jje=jj_end-1
+      
+      CALL  filtreg_p ( rotin ,jjb,jje,jjm, klevel,2, 1, .FALSE., 1)
+
+      CALL   nxgrad_p ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf_p  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rotgam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rotgam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rotgam.F	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+      SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c   ........................................................
+c
+c
+
+      CALL   nxgrad_gam ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil ( klevel, ghx  ,   ghy , rotout )
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jm
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rotgam_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rotgam_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/laplacien_rotgam_p.F	(revision 984)
@@ -0,0 +1,48 @@
+      SUBROUTINE laplacien_rotgam_p ( klevel, rotin, rotout )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c   ........................................................
+c
+      INTEGER :: ijb,ije
+      
+c
+
+      CALL   nxgrad_gam_p ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil_p ( klevel, ghx  ,   ghy , rotout )
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, klevel
+        DO ij = ijb, ije
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/leapfrog_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/leapfrog_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/leapfrog_p.F	(revision 984)
@@ -0,0 +1,1475 @@
+! 
+! $Header$
+!
+c
+c
+#define IO_DEBUG
+
+!#undef CPP_IOIPSL
+
+      SUBROUTINE leapfrog_p(ucov,vcov,teta,ps,masse,phis,nq,q,clesphy0,
+     &                    time_0)
+
+       USE misc_mod
+       USE parallel
+       USE times
+       USE mod_hallo
+       USE Bands
+       USE Write_Field
+       USE Write_Field_p
+       USE vampir
+
+      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 shema pour l'advection de
+c        q  , en modifiant iadv dans traceur.def  (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"
+
+c#include "tracstoke.h"
+
+#include "academic.h"
+#include "clesphys.h"
+#include "advtrac.h"
+      
+      include 'mpif.h'
+      integer nq
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      real zqmin,zqmax
+      INTEGER nbetatmoy, nbetatdem,nbetat
+
+c   variables dynamiques
+      REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL :: teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL :: q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL :: ps(ip1jmp1)                       ! pression  au sol
+      REAL,SAVE :: p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL,SAVE :: pks(ip1jmp1)                      ! exner au  sol
+      REAL,SAVE :: pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL,SAVE :: pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL :: masse(ip1jmp1,llm)                ! masse d'air
+      REAL :: phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL,SAVE :: phi(ip1jmp1,llm)                  ! geopotentiel
+      REAL,SAVE :: w(ip1jmp1,llm)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+      REAL,SAVE :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
+
+c   variables dynamiques au pas -1
+      REAL,SAVE :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL,SAVE :: tetam1(ip1jmp1,llm),psm1(ip1jmp1)
+      REAL,SAVE :: massem1(ip1jmp1,llm)
+
+c   tendances dynamiques
+      REAL,SAVE :: dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL,SAVE :: dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqmx),dp(ip1jmp1)
+
+c   tendances de la dissipation
+      REAL,SAVE :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
+      REAL,SAVE :: dtetadis(ip1jmp1,llm)
+
+c   tendances physiques
+      REAL,SAVE :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
+      REAL,SAVE :: dtetafi(ip1jmp1,llm)
+      REAL,SAVE :: dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1)
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL tppn(iim),tpps(iim),tpn,tps
+c
+      INTEGER itau,itaufinp1,iav
+      INTEGER*4  iday ! jour julien
+      REAL       time ! Heure de la journee en fraction d'1 jour
+
+      REAL  SSUM
+      REAL time_0 
+      REAL,SAVE :: finvmaold(ip1jmp1,llm)
+
+cym      LOGICAL  lafin
+      LOGICAL :: lafin
+      INTEGER ij,iq,l
+      INTEGER ik
+
+      real time_step, t_wrt, t_ops
+
+      REAL rdayvrai,rdaym_ini
+      LOGICAL first,callinigrads
+
+      data callinigrads/.true./
+      character*10 string10
+
+      REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+      REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale
+
+c+jld variables test conservation energie
+      REAL,SAVE :: 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,SAVE :: dtetaecdt(ip1jmp1,llm)
+      REAL,SAVE :: vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL,SAVE :: vnat(ip1jm,llm),unat(ip1jmp1,llm)
+      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+      CHARACTER*15 ztit
+!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+!      SAVE      ip_ebil_dyn
+!      DATA      ip_ebil_dyn/0/
+c-jld 
+
+      character*80 dynhist_file, dynhistave_file
+      character*20 modname
+      character*80 abort_message
+
+C Calendrier
+      LOGICAL true_calendar
+      PARAMETER (true_calendar = .false.)
+
+      logical,PARAMETER :: dissip_conservative=.TRUE.
+ 
+      INTEGER testita
+      PARAMETER (testita = 9)
+      
+c declaration liees au parallelisme
+      INTEGER :: ierr
+      LOGICAL :: FirstCaldyn
+      LOGICAL :: FirstPhysic
+      INTEGER :: ijb,ije,j,i
+      type(Request) :: TestRequest
+      type(Request) :: Request_Dissip
+      type(Request) :: Request_physic
+      REAL,SAVE :: dvfi_tmp(iip1,llm),dufi_tmp(iip1,llm)
+      REAL,SAVE :: dtetafi_tmp(iip1,llm),dqfi_tmp(iip1,llm,nqmx)
+      REAL,SAVE :: dpfi_tmp(iip1)
+
+      INTEGER :: true_itau
+      LOGICAL :: verbose=.true.
+      INTEGER :: iapptrac
+      INTEGER :: AdjustCount
+      INTEGER :: var_time
+      LOGICAL :: ok_start_timer=.FALSE.
+
+c$OMP MASTER
+      ItCount=0
+c$OMP END MASTER      
+      true_itau=0
+      FirstCaldyn=.TRUE.
+      FirstPhysic=.TRUE.
+      iapptrac=0
+      AdjustCount = 0
+      lafin=.false.
+      
+      itaufin   = nday*day_step
+      itaufinp1 = itaufin +1
+
+
+      itau = 0
+      iday = day_ini+itau/day_step
+      time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+         IF(time.GT.1.) THEN
+          time = time-1.
+          iday = iday+1
+         ENDIF
+
+c$OMP MASTER
+      OMP_CHUNK=5
+c$OMP END MASTER  
+c-----------------------------------------------------------------------
+c   On initialise la pression et la fonction d'Exner :
+c   --------------------------------------------------
+
+c$OMP MASTER
+      dq=0.
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+c et du parallelisme !!
+
+   1  CONTINUE
+
+c$OMP MASTER
+      call MPI_BARRIER(COMM_LMDZ,ierr)
+c$OMP END MASTER
+c$OMP BARRIER
+
+#ifdef CPP_IOIPSL
+c$OMP MASTER
+      if (ok_guide.and.(itaufin-itau-1)*dtvr.gt.21600) then
+        call guide_pp(itau,ucov,vcov,teta,q,masse,ps)
+      else
+        IF(prt_level>9)WRITE(*,*)'attention on ne guide pas les ',
+     .    '6 dernieres heures'
+      endif
+c$OMP END MASTER
+#endif
+c
+c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+c       CALL  test_period ( ucov,vcov,teta,q,p,phis )
+c       PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+c     ENDIF 
+c
+cym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+cym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+cym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+cym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+cym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+       if (FirstCaldyn) then
+c$OMP MASTER
+         ucovm1=ucov
+         vcovm1=vcov
+         tetam1= teta
+         massem1= masse
+         psm1= ps
+         
+         finvmaold = masse
+         CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+c$OMP END MASTER
+c$OMP BARRIER
+       else
+          
+         ijb=ij_begin
+         ije=ij_end
+
+c$OMP MASTER           
+         psm1     (ijb:ije) = ps    (ijb:ije)
+c$OMP END MASTER
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
+         DO l=1,llm      
+           ije=ij_end
+           ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
+           tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
+           massem1  (ijb:ije,l) = masse (ijb:ije,l)
+           finvmaold(ijb:ije,l)=masse(ijb:ije,l)
+                 
+           if (pole_sud) ije=ij_end-iip1
+           vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
+       
+
+         ENDDO
+c$OMP ENDDO          
+
+
+          CALL filtreg_p ( finvmaold ,jj_begin,jj_end,jjp1, 
+     .                    llm, -2,2, .TRUE., 1 )
+
+       endif
+       
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+
+c   ...    P.Le Van .26/04/94  ....
+
+cym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+cym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+cym  ne sert a rien
+cym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+
+   2  CONTINUE
+
+c$OMP MASTER
+      ItCount=ItCount+1
+      if (MOD(ItCount,1)==1) then
+        debug=.true.
+      else
+        debug=.false.
+      endif
+c$OMP END MASTER
+c-----------------------------------------------------------------------
+
+c   date:
+c   -----
+
+
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+c      idissip=1
+      IF( purmats ) THEN
+         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
+         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward 
+     s          .and. iflag_phys.NE.0                 ) apphys = .TRUE.
+      ELSE
+         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
+         IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.NE.0) apphys=.TRUE.
+      END IF
+
+cym    ---> Pour le moment      
+cym      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      
+      if (firstCaldyn) then
+c$OMP MASTER
+          call SetDistrib(jj_Nb_Caldyn)
+c$OMP END MASTER
+c$OMP BARRIER
+          firstCaldyn=.FALSE.
+cym          call InitTime
+c$OMP MASTER
+          call Init_timer
+c$OMP END MASTER
+      endif
+
+c$OMP MASTER      
+      IF (ok_start_timer) THEN
+        CALL InitTime
+        ok_start_timer=.FALSE.
+      ENDIF      
+c$OMP END MASTER      
+     
+      if (Adjust) then
+c$OMP MASTER 
+        AdjustCount=AdjustCount+1
+        if (iapptrac==iapp_tracvl .and. (forward. OR . leapf)
+     &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
+           AdjustCount=0
+           call allgather_timer_average
+
+        if (Verbose) then
+        
+        print *,'*********************************'
+        print *,'******    TIMER CALDYN     ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i),
+     &            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER VANLEER    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i),
+     &            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER DISSIP    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_dissip(i),timer_dissip,i),
+     &             '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
+        enddo
+        
+        if (mpi_rank==0) call WriteBands
+        
+       endif
+       
+         call AdjustBands_caldyn
+         if (mpi_rank==0) call WriteBands
+         
+         call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+         call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
+     &                                jj_Nb_caldyn,0,0,TestRequest)
+ 
+        do j=1,nqmx
+         call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     &                                jj_nb_caldyn,0,0,TestRequest)
+        enddo
+
+         call SetDistrib(jj_nb_caldyn)
+         call SendRequest(TestRequest)
+         call WaitRequest(TestRequest)
+         
+        call AdjustBands_dissip
+        call AdjustBands_physic
+
+      endif
+c$OMP END MASTER  
+      endif       
+     
+      
+      
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+c$OMP BARRIER
+c$OMP MASTER
+       call VTb(VThallo)
+       call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(teta,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(ps,ip1jmp1,1,1,2,2,1,TestRequest)
+       call Register_Hallo(pkf,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(pk,ip1jmp1,llm,1,1,1,1,TestRequest)
+       call Register_Hallo(pks,ip1jmp1,1,1,1,1,1,TestRequest)
+       call Register_Hallo(p,ip1jmp1,llmp1,1,1,1,1,TestRequest)
+       
+c       do j=1,nqmx
+c         call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
+c     *                       TestRequest)
+c        enddo
+
+       call SendRequest(TestRequest)
+       call WaitRequest(TestRequest)
+       call VTe(VThallo)
+
+      
+      if (debug) then        
+        call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+        call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+        call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+        call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+        call WriteField_p('masse',reshape(masse,(/iip1,jmp1,llm/)))
+        call WriteField_p('pk',reshape(pk,(/iip1,jmp1,llm/)))
+        call WriteField_p('pks',reshape(pks,(/iip1,jmp1/)))
+        call WriteField_p('pkf',reshape(pkf,(/iip1,jmp1,llm/)))
+        call WriteField_p('phis',reshape(phis,(/iip1,jmp1/)))
+        do j=1,nqmx
+          call WriteField_p('q'//trim(int2str(j)),
+     .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+        enddo        
+      endif
+c$OMP END MASTER 
+c$OMP BARRIER
+      
+      True_itau=True_itau+1
+
+c$OMP MASTER
+c     print*,"Iteration No",True_itau
+
+
+      call start_timer(timer_caldyn)
+
+      CALL geopot_p  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+      
+      call VTb(VTcaldyn)
+c$OMP END MASTER
+c$OMP BARRIER
+      var_time=time+iday-day_ini
+cc$OMP PARALLEL DEFAULT(SHARED)
+cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije,
+cc$OMP+                 tppn,tpn,tpps,tps)
+
+cc$OMP+         SHARED(itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+cc$OMP+                phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, 
+cc$OMP+                time, iday,day_ini,forward,leapf, iapptrac,
+cc$OMP+                q,dq,p,VTcaldyn,offline,dtvr,itau)      
+
+      CALL caldyn_p 
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time+iday-day_ini )
+
+ccc$OMP END PARALLEL      
+c$OMP MASTER
+      call VTe(VTcaldyn)
+c$OMP END MASTER      
+c      call WriteField_p('du',reshape(du,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dv',reshape(dv,(/iip1,jjm,llm/)))
+c      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dp',reshape(dp,(/iip1,jmp1/)))
+c      call WriteField_p('w',reshape(w,(/iip1,jmp1,llm/)))
+c      call WriteField_p('pbaru',reshape(pbaru,(/iip1,jmp1,llm/)))
+c      call WriteField_p('pbarv',reshape(pbarv,(/iip1,jjm,llm/)))
+
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+
+      IF( forward. OR . leapf )  THEN
+cc$OMP PARALLEL DEFAULT(SHARED) 
+c
+         CALL caladvtrac_p(q,pbaru,pbarv,
+     *        p, masse, dq,  teta,
+     .        flxw,pk, iapptrac)
+         
+c      do j=1,nqmx
+c        call WriteField_p('q'//trim(int2str(j)),
+c     .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+c        call WriteField_p('dq'//trim(int2str(j)),
+c     .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
+c      enddo
+       IF (offline) THEN
+Cmaf stokage du flux de masse pour traceurs OFF-LINE
+#undef CPP_IOIPSL
+#ifdef CPP_IOIPSL
+           CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     .   dtvr, itau)
+#endif
+
+
+         ENDIF
+c
+      ENDIF
+cc$OMP END PARALLEL
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+c$OMP MASTER 
+       call VTb(VTintegre)
+c$OMP END MASTER
+c      call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/)))
+c      call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/)))
+c      call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c      call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+cc$OMP PARALLEL DEFAULT(SHARED)
+       CALL integrd_p ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
+     $              finvmaold                                    )
+
+
+c      call WriteField_p('ucovm1',reshape(ucovm1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcovm1',reshape(vcovm1,(/iip1,jjm,llm/)))
+c      call WriteField_p('tetam1',reshape(tetam1,(/iip1,jmp1,llm/)))
+c      call WriteField_p('psm1',reshape(psm1,(/iip1,jmp1/)))
+c      call WriteField_p('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c      call WriteField_p('teta',reshape(teta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dteta',reshape(dteta,(/iip1,jmp1,llm/)))
+
+c      call WriteField_p('ps',reshape(ps,(/iip1,jmp1/)))
+c$OMP MASTER 
+       call VTe(VTintegre)
+c$OMP END MASTER
+c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+c
+c-----------------------------------------------------------------------
+c   calcul des tendances physiques:
+c   -------------------------------
+c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+c
+       IF( purmats )  THEN
+          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+       ELSE
+          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
+       ENDIF
+
+cc$OMP END PARALLEL
+
+c
+c
+       IF( apphys )  THEN
+c
+c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+c
+cc$OMP PARALLEL DEFAULT(SHARED)
+cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
+
+c$OMP MASTER
+         call suspend_timer(timer_caldyn)
+c        print*,'Entree dans la physique : Iteration No ',true_itau
+c$OMP END MASTER
+
+c$OMP BARRIER
+         CALL pression_p (  ip1jmp1, ap, bp, ps,  p      )
+
+         CALL exner_hyb_p(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
+           rdaym_ini  = itau * dtvr / daysec
+           rdayvrai   = rdaym_ini  + day_ini
+
+
+c rajout debug
+c       lafin = .true.
+
+
+c   Inbterface avec les routines de phylmd (phymars ... )
+c   -----------------------------------------------------
+
+#ifdef CPP_PHYS
+c+jld
+
+c  Diagnostique de conservation de l'energie : initialisation
+      IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil dyn'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+      ENDIF 
+c-jld
+c$OMP BARRIER
+c$OMP MASTER
+        call VTb(VThallo)
+        call SetTag(Request_physic,800)
+        
+        call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(p,p,ip1jmp1,llmp1,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+        call Register_SwapFieldHallo(w,w,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        
+c        call SetDistrib(jj_nb_vanleer)
+        do j=1,nqmx
+ 
+          call Register_SwapFieldHallo(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        enddo
+
+        call Register_SwapFieldHallo(flxw,flxw,ip1jmp1,llm,
+     *                               jj_Nb_physic,2,2,Request_physic)
+        call SetDistrib(jj_nb_Physic)
+        
+        call SendRequest(Request_Physic)
+        call WaitRequest(Request_Physic)       
+        
+        call VTe(VThallo)
+        
+        call VTb(VTphysiq)
+c$OMP END MASTER
+c$OMP BARRIER
+
+cc$OMP MASTER        
+c      call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/)))
+c      call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/)))
+c      call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/)))
+c      call WriteField_p('pfi',reshape(p,(/iip1,jmp1,llmp1/)))
+c      call WriteField_p('pkfi',reshape(pk,(/iip1,jmp1,llm/)))
+cc$OMP END MASTER
+cc$OMP BARRIER
+        
+        CALL calfis_p( nq, lafin ,rdayvrai,time  ,
+     $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+     $               du,dv,dteta,dq,
+     $               flxw,
+     $               clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi  )
+        ijb=ij_begin
+        ije=ij_end  
+        if ( .not. pole_nord) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l) 
+          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)  
+          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)  
+          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)  
+          ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)  
+c$OMP END MASTER
+        endif
+
+c$OMP BARRIER
+c$OMP MASTER
+        call SetDistrib(jj_nb_Physic_bis)
+
+        call VTb(VThallo)
+ 
+        call Register_Hallo(dufi,ip1jmp1,llm,
+     *                      1,0,0,1,Request_physic)
+        
+        call Register_Hallo(dvfi,ip1jm,llm,
+     *                      1,0,0,1,Request_physic)
+        
+        call Register_Hallo(dtetafi,ip1jmp1,llm,
+     *                      1,0,0,1,Request_physic)
+
+        call Register_Hallo(dpfi,ip1jmp1,1,
+     *                      1,0,0,1,Request_physic)
+
+        do j=1,nqmx
+          call Register_Hallo(dqfi(1,1,j),ip1jmp1,llm,
+     *                        1,0,0,1,Request_physic)
+        enddo
+        
+        call SendRequest(Request_Physic)
+        call WaitRequest(Request_Physic)
+             
+        call VTe(VThallo)
+ 
+        call SetDistrib(jj_nb_Physic)
+c$OMP END MASTER
+c$OMP BARRIER        
+                ijb=ij_begin
+        if (.not. pole_nord) then
+        
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) 
+            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
+     &                              +dtetafi_tmp(1:iip1,l)
+            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
+     &                              + dqfi_tmp(1:iip1,l,:)
+          ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+c$OMP END MASTER
+          
+        endif
+c$OMP BARRIER
+cc$OMP MASTER        
+c      call WriteField_p('dufi',reshape(dufi,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dvfi',reshape(dvfi,(/iip1,jjm,llm/)))
+c      call WriteField_p('dtetafi',reshape(dtetafi,(/iip1,jmp1,llm/)))
+c      call WriteField_p('dpfi',reshape(dpfi,(/iip1,jmp1/)))
+cc$OMP END MASTER
+c      
+c      do j=1,nqmx
+c        call WriteField_p('dqfi'//trim(int2str(j)),
+c     .                reshape(dqfi(:,:,j),(/iip1,jmp1,llm/)))
+c      enddo
+
+c      ajout des tendances physiques:
+c      ------------------------------
+          CALL addfi_p( nqmx, dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps ,
+     $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+
+c$OMP BARRIER
+c$OMP MASTER
+        call VTe(VTphysiq)
+
+        call VTb(VThallo)
+
+        call SetTag(Request_physic,800)
+        call Register_SwapField(ucov,ucov,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(vcov,vcov,ip1jm,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(teta,teta,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(p,p,ip1jmp1,llmp1,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(pk,pk,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(phis,phis,ip1jmp1,1,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(phi,phi,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        call Register_SwapField(w,w,ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+
+        do j=1,nqmx
+        
+          call Register_SwapField(q(1,1,j),q(1,1,j),ip1jmp1,llm,
+     *                               jj_Nb_caldyn,Request_physic)
+        
+        enddo
+
+        call SendRequest(Request_Physic)
+        call WaitRequest(Request_Physic)     
+
+        call VTe(VThallo)
+
+        call SetDistrib(jj_Nb_caldyn)
+c$OMP END MASTER
+c$OMP BARRIER
+c
+c  Diagnostique de conservation de l'energie : difference
+      IF (ip_ebil_dyn.ge.1 ) THEN 
+          ztit='bil phys'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+      ENDIF 
+
+cc$OMP MASTER      
+c      if (debug) then
+c       call WriteField_p('ucovfi',reshape(ucov,(/iip1,jmp1,llm/)))
+c       call WriteField_p('vcovfi',reshape(vcov,(/iip1,jjm,llm/)))
+c       call WriteField_p('tetafi',reshape(teta,(/iip1,jmp1,llm/)))
+c      endif
+cc$OMP END MASTER
+
+#else
+
+c   Calcul academique de la physique = Rappel Newtonien + fritcion 
+c   --------------------------------------------------------------
+cym       teta(:,:)=teta(:,:)
+cym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+       ijb=ij_begin
+       ije=ij_end
+       teta(ijb:ije,:)=teta(ijb:ije,:)
+     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
+
+       call Register_Hallo(ucov,ip1jmp1,llm,0,1,1,0,Request_Physic)
+       call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Physic)
+       call SendRequest(Request_Physic)
+       call WaitRequest(Request_Physic)     
+
+       call friction_p(ucov,vcov,iphysiq*dtvr)
+
+#endif
+
+c-jld
+c$OMP MASTER
+         call resume_timer(timer_caldyn)
+         if (FirstPhysic) then
+           ok_start_timer=.TRUE.
+           FirstPhysic=.false.
+         endif
+c$OMP END MASTER
+       ENDIF
+
+c$OMP BARRIER
+        CALL pression_p ( ip1jmp1, ap, bp, ps, p                  )
+        CALL exner_hyb_p( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+c$OMP BARRIER
+
+cc$OMP END PARALLEL
+
+c-----------------------------------------------------------------------
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+      IF(apdiss) THEN
+cc$OMP  PARALLEL DEFAULT(SHARED) 
+cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
+c$OMP MASTER
+        call suspend_timer(timer_caldyn)
+        
+c       print*,'Entree dans la dissipation : Iteration No ',true_itau
+c   calcul de l'energie cinetique avant dissipation
+c       print *,'Passage dans la dissipation'
+
+        call VTb(VThallo)
+c$OMP END MASTER
+
+c$OMP BARRIER
+c$OMP MASTER
+        call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+     *                          jj_Nb_dissip,1,1,Request_dissip)
+
+        call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+     *                          jj_Nb_dissip,1,1,Request_dissip)
+
+        call Register_SwapField(teta,teta,ip1jmp1,llm,
+     *                          jj_Nb_dissip,Request_dissip)
+
+        call Register_SwapField(p,p,ip1jmp1,llmp1,
+     *                          jj_Nb_dissip,Request_dissip)
+
+        call Register_SwapField(pk,pk,ip1jmp1,llm,
+     *                          jj_Nb_dissip,Request_dissip)
+
+        call SendRequest(Request_dissip)       
+        call WaitRequest(Request_dissip)       
+        call SetDistrib(jj_Nb_dissip)
+        
+        call VTe(VThallo)
+
+        call VTb(VTdissipation)
+        
+        call start_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+        call covcont_p(llm,ucov,vcov,ucont,vcont)
+        call enercin_p(vcov,ucov,vcont,ucont,ecin0)
+
+c   dissipation
+
+        CALL dissip_p(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+         
+        ijb=ij_begin
+        ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+        DO l=1,llm
+          ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+        ENDDO
+c$OMP END DO NOWAIT        
+        if (pole_sud) ije=ije-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+        DO l=1,llm
+          vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+        ENDDO
+c$OMP END DO NOWAIT        
+
+c       teta=teta+dtetadis
+
+
+c------------------------------------------------------------------------
+        if (dissip_conservative) then
+C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+C       lors de la dissipation
+c$OMP BARRIER
+c$OMP MASTER
+            call suspend_timer(timer_dissip)
+            call VTb(VThallo)
+
+            call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Request_Dissip)
+            call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Request_Dissip)
+            call SendRequest(Request_Dissip)
+            call WaitRequest(Request_Dissip)
+            call VTe(VThallo)
+            call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER            
+            call covcont_p(llm,ucov,vcov,ucont,vcont)
+            call enercin_p(vcov,ucov,vcont,ucont,ecin)
+            
+            ijb=ij_begin
+            ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+            do l=1,llm
+              do ij=ijb,ije
+                dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+                dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+              enddo
+            enddo
+c$OMP END DO NOWAIT            
+       endif
+
+       ijb=ij_begin
+       ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+         do l=1,llm
+           do ij=ijb,ije
+              teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+           enddo
+         enddo
+c$OMP END DO NOWAIT         
+c------------------------------------------------------------------------
+
+
+c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+c
+
+        ijb=ij_begin
+        ije=ij_end
+         
+        if (pole_nord) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l  =  1, llm
+            DO ij =  1,iim
+             tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+            ENDDO
+             tpn  = SSUM(iim,tppn,1)/apoln
+
+            DO ij = 1, iip1
+             teta(  ij    ,l) = tpn
+            ENDDO
+          ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER               
+          DO ij =  1,iim
+            tppn(ij)  = aire(  ij    ) * ps (  ij    )
+          ENDDO
+            tpn  = SSUM(iim,tppn,1)/apoln
+  
+          DO ij = 1, iip1
+            ps(  ij    ) = tpn
+          ENDDO
+c$OMP END MASTER
+        endif
+        
+        if (pole_sud) then
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l  =  1, llm
+            DO ij =  1,iim
+             tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+            ENDDO
+             tps  = SSUM(iim,tpps,1)/apols
+
+            DO ij = 1, iip1
+             teta(ij+ip1jm,l) = tps
+            ENDDO
+          ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER               
+          DO ij =  1,iim
+            tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+          ENDDO
+            tps  = SSUM(iim,tpps,1)/apols
+  
+          DO ij = 1, iip1
+            ps(ij+ip1jm) = tps
+          ENDDO
+c$OMP END MASTER
+        endif
+
+
+c$OMP BARRIER
+c$OMP MASTER
+        call VTe(VTdissipation)
+
+        call stop_timer(timer_dissip)
+        
+        call VTb(VThallo)
+
+        call Register_SwapField(ucov,ucov,ip1jmp1,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(vcov,vcov,ip1jm,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(teta,teta,ip1jmp1,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(p,p,ip1jmp1,llmp1,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call Register_SwapField(pk,pk,ip1jmp1,llm,
+     *                          jj_Nb_caldyn,Request_dissip)
+
+        call SendRequest(Request_dissip)       
+        call WaitRequest(Request_dissip)       
+        call SetDistrib(jj_Nb_caldyn)
+        call VTe(VThallo)
+        call resume_timer(timer_caldyn)
+c        print *,'fin dissipation'
+c$OMP END MASTER
+      END IF
+
+cc$OMP END PARALLEL
+
+c ajout debug
+c              IF( lafin ) then  
+c                abort_message = 'Simulation finished'
+c                call abort_gcm(modname,abort_message,0)
+c              ENDIF
+        
+c   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+
+c   preparation du pas d'integration suivant  ......
+cym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+cym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+c$OMP MASTER      
+      call stop_timer(timer_caldyn)
+c$OMP END MASTER
+      IF (itau==itaumax) then
+c$OMP MASTER
+            call allgather_timer_average
+
+      if (mpi_rank==0) then
+        
+        print *,'*********************************'
+        print *,'******    TIMER CALDYN     ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER VANLEER    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+        enddo
+      
+        print *,'*********************************'
+        print *,'******    TIMER DISSIP    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_dissip(i),timer_dissip,i)
+        enddo
+        
+        print *,'*********************************'
+        print *,'******    TIMER PHYSIC    ******'
+        do i=0,mpi_size-1
+          print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i),
+     &            '  : temps moyen :',
+     &             timer_average(jj_nb_physic(i),timer_physic,i)
+        enddo
+        
+      endif  
+      
+      print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
+      print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
+      print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
+      print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
+
+        call finalize_parallel
+c$OMP END MASTER
+        RETURN
+      ENDIF
+      
+      IF ( .NOT.purmats ) THEN
+c       ........................................................
+c       ..............  schema matsuno + leapfrog  ..............
+c       ........................................................
+
+            IF(forward. OR. leapf) THEN
+              itau= itau + 1
+              iday= day_ini+itau/day_step
+              time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+                IF(time.GT.1.) THEN
+                  time = time-1.
+                  iday = iday+1
+                ENDIF
+            ENDIF
+
+
+            IF( itau. EQ. itaufinp1 ) then  
+
+c$OMP MASTER
+              call finalize_parallel
+c$OMP END MASTER
+              abort_message = 'Simulation finished'
+              call abort_gcm(modname,abort_message,0)
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+c$OMP BARRIER
+c$OMP MASTER
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+#ifdef CPP_IOIPSL
+             call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest)
+              call SendRequest(TestRequest)
+              call WaitRequest(TestRequest)
+
+              CALL writedynav_p(histaveid, nqmx, itau,vcov ,
+     ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+c               call bilan_dyn_p(2,dtvr*iperiod,dtvr*day_step*periodav,
+c     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+#endif
+c$OMP END MASTER
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   ecriture de la bande histoire:
+c   ------------------------------
+
+c      IF( MOD(itau,iecri         ).EQ.0) THEN
+
+           IF( MOD(itau,iecri*day_step).EQ.0) THEN
+c$OMP BARRIER
+c$OMP MASTER
+               nbetat = nbetatdem
+        CALL geopot_p  ( ip1jmp1, teta  , pk , pks,  phis  , phi )
+       
+cym        unat=0.
+        
+        ijb=ij_begin
+        ije=ij_end
+        
+        if (pole_nord) then
+          ijb=ij_begin+iip1
+          unat(1:iip1,:)=0.
+        endif
+        
+        if (pole_sud) then 
+          ije=ij_end-iip1
+          unat(ij_end-iip1+1:ij_end,:)=0.
+        endif
+            
+        do l=1,llm
+           unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije)
+        enddo
+
+        ijb=ij_begin
+        ije=ij_end
+        if (pole_sud) ije=ij_end-iip1
+        
+        do l=1,llm
+           vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije)
+        enddo
+        
+#ifdef CPP_IOIPSL
+ 
+        CALL writehist_p(histid,histvid, nqmx,itau,vcov, 
+     s                       ucov,teta,phi,q,masse,ps,phis)
+c#else
+c       call Gather_Field(unat,ip1jmp1,llm,0)
+c       call Gather_Field(vnat,ip1jm,llm,0)
+c       call Gather_Field(teta,ip1jmp1,llm,0)
+c       call Gather_Field(ps,ip1jmp1,1,0)
+c       do iq=1,nqmx
+c        call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+c       enddo
+c      
+c       if (mpi_rank==0) then
+c#include "write_grads_dyn.h"
+c       endif
+#endif
+c$OMP END MASTER
+           ENDIF
+
+            IF(itau.EQ.itaufin) THEN
+
+c$OMP BARRIER
+c$OMP MASTER
+
+c#ifdef CPP_IOIPSL
+
+       CALL dynredem1_p("restart.nc",0.0,
+     ,                     vcov,ucov,teta,q,nqmx,masse,ps)
+c#endif
+
+              CLOSE(99)
+c$OMP END MASTER
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2
+                   END IF
+            ELSE
+
+c      ......   pas leapfrog  .....
+
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF
+
+      ELSE
+
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+
+             itau =  itau + 1
+             iday = day_ini+itau/day_step
+             time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+
+                  IF(time.GT.1.) THEN
+                   time = time-1.
+                   iday = iday+1
+                  ENDIF
+
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then  
+c$OMP MASTER
+                 call finalize_parallel
+c$OMP END MASTER
+                 abort_message = 'Simulation finished'
+                 call abort_gcm(modname,abort_message,0)
+               ENDIF
+               GO TO 2
+
+            ELSE
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+#ifdef CPP_IOIPSL
+c$OMP BARRIER
+c$OMP MASTER
+
+              call Register_Hallo(vcov,ip1jm,llm,1,0,0,1,TestRequest)
+              call SendRequest(TestRequest)
+              call WaitRequest(TestRequest)
+
+              CALL writedynav_p(histaveid, nqmx, itau,vcov ,
+     ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+c               call bilan_dyn_p (2,dtvr*iperiod,dtvr*day_step*periodav,
+c     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+c$OMP END MASTER
+#endif
+            ENDIF
+
+c               IF(MOD(itau,iecri         ).EQ.0) THEN
+              IF(MOD(itau,iecri*day_step).EQ.0) THEN
+c$OMP BARRIER
+c$OMP MASTER
+                  nbetat = nbetatdem
+       CALL geopot_p( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+cym        unat=0.
+        ijb=ij_begin
+        ije=ij_end
+        
+        if (pole_nord) then
+          ijb=ij_begin+iip1
+          unat(1:iip1,:)=0.
+        endif
+        
+        if (pole_sud) then 
+          ije=ij_end-iip1
+          unat(ij_end-iip1+1:ij_end,:)=0.
+        endif
+            
+        do l=1,llm
+           unat(ijb:ije,l)=ucov(ijb:ije,l)/cu(ijb:ije)
+        enddo
+
+        ijb=ij_begin
+        ije=ij_end
+        if (pole_sud) ije=ij_end-iip1
+        
+        do l=1,llm
+           vnat(ijb:ije,l)=vcov(ijb:ije,l)/cv(ijb:ije)
+        enddo
+
+#ifdef CPP_IOIPSL
+
+       CALL writehist_p( histid, histvid, nqmx, itau,vcov , 
+     ,                           ucov,teta,phi,q,masse,ps,phis)
+c#else
+c      call Gather_Field(unat,ip1jmp1,llm,0)
+c      call Gather_Field(vnat,ip1jm,llm,0)
+c      call Gather_Field(teta,ip1jmp1,llm,0)
+c      call Gather_Field(ps,ip1jmp1,1,0)
+c      do iq=1,nqmx
+c        call Gather_Field(q(1,1,iq),ip1jmp1,llm,0)
+c      enddo
+c      
+c      if (mpi_rank==0) then
+c#include "write_grads_dyn.h"
+c      endif
+#endif
+
+c$OMP END MASTER
+               ENDIF
+
+                 IF(itau.EQ.itaufin) THEN
+c$OMP MASTER
+                   CALL dynredem1_p("restart.nc",0.0,
+     .                               vcov,ucov,teta,q,nqmx,masse,ps)
+c$OMP END MASTER
+                 ENDIF
+                 forward = .TRUE.
+                 GO TO  1
+
+            ENDIF
+
+      END IF
+c$OMP MASTER
+        call finalize_parallel
+c$OMP END MASTER
+        RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/limx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/limx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/limx.F	(revision 984)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE limx(s0,sx,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+      real sx(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL q(ip1jmp1,llm)
+      real dxq(ip1jmp1,llm)
+
+
+      REAL new_m,zm
+      real dxqu(ip1jmp1)
+      real adxqu(ip1jmp1),dxqmax(ip1jmp1)
+
+      Logical extremum,first
+      save first
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+      EXTERNAL  SSUM, ismin,ismax
+
+      data first/.true./
+
+
+       DO  l = 1,llm
+         DO  ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dxq(ij,l) = sx(ij,l) /sm(ij,l)
+         ENDDO
+       ENDDO
+
+c   calcul de la pente a droite et a gauche de la maille
+
+      do l = 1, llm
+         do ij=iip2,ip1jm-1
+            dxqu(ij)=q(ij+1,l)-q(ij,l)
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqu(ij)=dxqu(ij-iim)
+         enddo
+
+         do ij=iip2,ip1jm
+            adxqu(ij)=abs(dxqu(ij))
+         enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+         do ij=iip2+1,ip1jm
+            dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
+         enddo
+
+         do ij=iip1+iip1,ip1jm,iip1
+            dxqmax(ij-iim)=dxqmax(ij)
+         enddo
+
+c   calcul de la pente avec limitation
+
+         do ij=iip2+1,ip1jm
+            if(     dxqu(ij-1)*dxqu(ij).gt.0.
+     &         .and. dxq(ij,l)*dxqu(ij).gt.0.) then
+              dxq(ij,l)=
+     &         sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
+            else
+c   extremum local
+               dxq(ij,l)=0.
+            endif
+         enddo
+         do ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         enddo
+
+         DO  ij=1,ip1jmp1
+               sx(ij,l) = dxq(ij,l)*sm(ij,l)
+         ENDDO
+
+       ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/limy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/limy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/limy.F	(revision 984)
@@ -0,0 +1,193 @@
+!
+! $Header$
+!
+      SUBROUTINE limy(s0,sy,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL q(ip1jmp1,llm)
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      real sigv,dyq(ip1jmp1),dyqv(ip1jm)
+      real adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2
+      Logical extremum,first
+      save first
+
+      real convpn,convps,convmpn,convmps
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      save sinlon,coslon,sinlondlon,coslondlon
+c
+c
+      REAL      SSUM
+      integer ismax,ismin
+      EXTERNAL  SSUM, ismin,ismax
+
+      data first/.true./
+
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+      endif
+
+c
+
+      do l = 1, llm
+c
+         DO ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dyq(ij) = sy(ij,l) / sm ( ij,l )
+         ENDDO
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      airej2 = SSUM( iim, aire(iip2), 1 )
+      airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      do ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      do ij=iip2,ip1jm
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      enddo
+
+c   calcul des pentes aux poles
+
+c   calcul des pentes limites aux poles
+
+c     print*,dyqv(iip1+1)
+c     apn=abs(dyq(1)/dyqv(iip1+1))
+c     print*,dyq(ip1jm+1)
+c     print*,dyqv(ip1jm-iip1+1)
+c     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+c     do ij=2,iim
+c        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+c        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+c     enddo
+c     apn=min(pente_max/apn,1.)
+c     aps=min(pente_max/aps,1.)
+
+
+c   cas ou on a un extremum au pole
+
+c     if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+c    &   apn=0.
+c     if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+c    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+c    &   aps=0.
+
+c   limitation des pentes aux poles
+c     do ij=1,iip1
+c        dyq(ij)=apn*dyq(ij)
+c        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+c     enddo
+
+c   test
+c      do ij=1,iip1
+c         dyq(iip1+ij)=0.
+c         dyq(ip1jm+ij-iip1)=0.
+c      enddo
+c      do ij=1,ip1jmp1
+c         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+c      enddo
+
+      if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+     &   then
+         do ij=1,iip1
+            dyqmax(ij)=0.
+         enddo
+      else
+         do ij=1,iip1
+            dyqmax(ij)=pente_max*abs(dyqv(ij))
+         enddo
+      endif
+
+      if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+     & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+     &then
+         do ij=ip1jm+1,ip1jmp1
+            dyqmax(ij)=0.
+         enddo
+      else
+         do ij=ip1jm+1,ip1jmp1
+            dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+         enddo
+      endif
+
+c   calcul des pentes limitees
+
+      do ij=1,ip1jmp1
+         if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then
+            dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij))
+         else
+            dyq(ij)=0.
+         endif
+      enddo
+
+         DO ij=1,ip1jmp1
+               sy(ij,l) = dyq(ij) * sm ( ij,l )
+        ENDDO
+
+      enddo ! fin de la boucle sur les couches verticales
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/limz.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/limz.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/limz.F	(revision 984)
@@ -0,0 +1,99 @@
+!
+! $Header$
+!
+      SUBROUTINE limz(s0,sz,sm,pente_max)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      real pente_max
+      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+      real sz(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL q(ip1jmp1,llm)
+      real dzq(ip1jmp1,llm)
+
+
+      REAL new_m,zm
+      real dzqw(ip1jmp1)
+      real adzqw(ip1jmp1),dzqmax(ip1jmp1)
+
+      Logical extremum,first
+      save first
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+      EXTERNAL  SSUM, ismin,ismax
+
+      data first/.true./
+
+
+       DO  l = 1,llm
+         DO  ij=1,ip1jmp1
+               q(ij,l) = s0(ij,l) / sm ( ij,l )
+               dzq(ij,l) = sz(ij,l) /sm(ij,l)
+         ENDDO
+       ENDDO
+
+c   calcul de la pente en haut et en bas de la maille
+       do ij=1,ip1jmp1
+       do l = 1, llm-1
+            dzqw(l)=q(ij,l+1)-q(ij,l)
+         enddo
+            dzqw(llm)=0.
+
+         do  l=1,llm
+            adzqw(l)=abs(dzqw(l))
+         enddo
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+         do l=2,llm-1
+            dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l))
+         enddo
+
+c   calcul de la pente avec limitation
+
+         do l=2,llm-1
+            if(     dzqw(l-1)*dzqw(l).gt.0.
+     &         .and. dzq(ij,l)*dzqw(l).gt.0.) then
+              dzq(ij,l)=
+     &         sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l))
+            else
+c   extremum local
+               dzq(ij,l)=0.
+            endif
+         enddo
+
+         DO  l=1,llm
+               sz(ij,l) = dzq(ij,l)*sm(ij,l)
+         ENDDO
+
+       ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/logic.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/logic.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/logic.h	(revision 984)
@@ -0,0 +1,19 @@
+!
+! $Header$
+!
+c
+c
+c-----------------------------------------------------------------------
+c INCLUDE 'logic.h'
+
+      COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys,
+     .  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus
+     .  ,read_start,ok_guide
+
+      LOGICAL purmats,forward,leapf,apphys,statcl,conser,
+     . apdiss,apdelq,saison,ecripar,fxyhypb,ysinus
+     .  ,read_start,ok_guide
+
+      INTEGER iflag_phys
+c$OMP THREADPRIVATE(/logic/)
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbar.F	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE massbar(  masse, massebx, masseby )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO  ij = 1, ip1jmp1 - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jmp1, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+         DO  ij = 1,ip1jm
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbar_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbar_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbar_p.F	(revision 984)
@@ -0,0 +1,117 @@
+      SUBROUTINE massbar_p(  masse, massebx, masseby )
+     
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+      INTEGER ij,l,ijb,ije
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+      
+      
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+      DO   100    l = 1 , llm
+c
+        ijb=ij_begin
+        ije=ij_end+iip1
+        if (pole_sud) ije=ije-iip1
+        
+        DO  ij = ijb, ije - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+
+        
+
+        DO  ij = ijb+iim, ije+iim, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+      
+        ijb=ij_begin-iip1
+        ije=ij_end+iip1
+        if (pole_nord) ijb=ij_begin
+        if (pole_sud) ije=ij_end-iip1
+
+         DO  ij = ijb,ije
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbarxy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbarxy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbarxy.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE massbarxy(  masse, massebxy )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = 1, ip1jm - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbarxy_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbarxy_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/massbarxy_p.F	(revision 984)
@@ -0,0 +1,55 @@
+      SUBROUTINE massbarxy_p(  masse, massebxy )
+      USE parallel
+      implicit none
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+      INTEGER ij,l,ijb,ije
+
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = ijb, ije - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = ijb+iip1-1, ije+iip1-1, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/massdair.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/massdair.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/massdair.F	(revision 984)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE massdair( p, masse )
+c
+c *********************************************************************
+c       ....  Calcule la masse d'air  dans chaque maille   ....
+c *********************************************************************
+c
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..    p                      est  un argum. d'entree pour le s-pg ...
+c  ..  masse                    est un  argum.de sortie pour le s-pg ...
+c     
+c  ....  p est defini aux interfaces des llm couches   .....
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c  .....   arguments  ....
+c
+      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
+
+c   ....  Variables locales  .....
+
+      INTEGER l,ij
+      REAL massemoyn, massemoys
+
+      REAL SSUM
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO    ij     = 1, ip1jmp1
+         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+        ENDDO
+c
+        DO   ij = 1, ip1jmp1,iip1
+         masse(ij+ iim,l) = masse(ij,l)
+        ENDDO
+c
+c       DO    ij     = 1,  iim
+c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
+c       ENDDO
+c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+c       DO    ij     = 1, iip1
+c        masse(   ij   ,l )    = massemoyn
+c        masse(ij+ip1jm,l )    = massemoys
+c       ENDDO
+       
+100   CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/massdair_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/massdair_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/massdair_p.F	(revision 984)
@@ -0,0 +1,120 @@
+      SUBROUTINE massdair_p( p, masse )
+      USE parallel
+c
+c *********************************************************************
+c       ....  Calcule la masse d'air  dans chaque maille   ....
+c *********************************************************************
+c
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..    p                      est  un argum. d'entree pour le s-pg ...
+c  ..  masse                    est un  argum.de sortie pour le s-pg ...
+c     
+c  ....  p est defini aux interfaces des llm couches   .....
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c  .....   arguments  ....
+c
+      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
+
+c   ....  Variables locales  .....
+
+      INTEGER l,ij
+      INTEGER ijb,ije
+      REAL massemoyn, massemoys
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      
+
+      
+      ijb=ij_begin-iip1
+      ije=ij_end+2*iip1
+      
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO   100    l = 1 , llm
+c
+        DO    ij     = ijb, ije
+         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+        ENDDO
+c
+        DO   ij = ijb, ije,iip1
+         masse(ij+ iim,l) = masse(ij,l)
+        ENDDO
+c
+c       DO    ij     = 1,  iim
+c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
+c       ENDDO
+c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+c       DO    ij     = 1, iip1
+c        masse(   ij   ,l )    = massemoyn
+c        masse(ij+ip1jm,l )    = massemoys
+c       ENDDO
+       
+100   CONTINUE
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/minmax.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/minmax.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/minmax.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/minmax2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/minmax2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/minmax2.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_const_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_const_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_const_para.F90	(revision 984)
@@ -0,0 +1,36 @@
+MODULE mod_const_mpi
+
+  INTEGER :: COMM_LMDZ
+  INTEGER :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+    USE IOIPSL
+
+    IMPLICIT NONE
+    INCLUDE 'mpif.h'
+    INTEGER             :: ierr
+    INTEGER             :: comp_id
+    CHARACTER(len = 6)  :: ocean
+
+!$OMP MASTER
+    ocean = 'force '
+    CALL getin('OCEAN', ocean)
+!$OMP END
+
+    IF (ocean=='couple') THEN
+#ifdef CPP_COUPLE
+       CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr)
+       CALL prism_get_localcomm_proto(COMM_LMDZ,ierr)
+#endif
+    ELSE
+       CALL MPI_INIT(ierr)
+       COMM_LMDZ=MPI_COMM_WORLD
+    END IF
+
+    MPI_REAL_LMDZ=MPI_REAL8
+  END SUBROUTINE Init_const_mpi
+
+END MODULE mod_const_mpi
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_hallo.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_hallo.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_hallo.F90	(revision 984)
@@ -0,0 +1,717 @@
+module mod_Hallo
+USE parallel
+implicit none
+
+  integer, parameter :: MaxRequest=200
+  integer, parameter :: MaxProc=80
+  integer, parameter :: MaxBufferSize=1024*1024*16
+  integer, parameter :: ListSize=1000
+  
+  integer,save       :: MaxBufferSize_Used
+ 
+    real,save,pointer,dimension(:) :: Buffer
+
+   integer,dimension(Listsize) :: Buffer_Pos
+   integer :: Index_Pos
+   
+  type Hallo
+    real, dimension(:,:),pointer :: Field
+    integer :: offset
+    integer :: size
+    integer :: NbLevel
+    integer :: Stride
+  end type Hallo
+  
+  type request_SR
+    integer :: NbRequest=0
+    integer :: Pos
+    integer :: Index 
+    type(Hallo),dimension(MaxRequest) :: Hallo
+    integer :: MSG_Request
+  end type request_SR
+
+  type request
+    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
+    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
+    integer :: tag=1
+  end type request
+  
+    
+  contains
+
+  subroutine Init_mod_hallo
+    implicit none
+
+    Index_Pos=1
+    Buffer_Pos(Index_Pos)=1
+    MaxBufferSize_Used=0
+
+    CALL create_global_mpi_buffer
+    
+  end subroutine init_mod_hallo
+
+
+  SUBROUTINE create_standard_mpi_buffer
+  IMPLICIT NONE
+    
+    ALLOCATE(Buffer(MaxBufferSize))
+    
+  END SUBROUTINE create_standard_mpi_buffer
+  
+
+  SUBROUTINE create_global_mpi_buffer
+  IMPLICIT NONE
+  INCLUDE 'mpif.h'  
+    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
+    REAL :: MPI_Buffer
+    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
+    INTEGER :: i,ierr
+
+
+      Bs=8*MaxBufferSize
+      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
+      DO i=1,MaxBufferSize
+	MPI_Buffer(i)=i
+      ENDDO
+     
+      CALL  Associate_buffer(MPI_Buffer)
+      
+  CONTAINS
+     
+     SUBROUTINE Associate_buffer(MPI_Buffer)
+     IMPLICIT NONE
+       REAL,DIMENSION(:),target :: MPI_Buffer  
+
+         Buffer=>MPI_Buffer
+ 
+      END SUBROUTINE  Associate_buffer
+                                      
+  END SUBROUTINE create_global_mpi_buffer
+
+
+      
+  subroutine allocate_buffer(Size,Index,Pos)
+  implicit none
+    integer :: Size
+    integer :: Index
+    integer :: Pos
+
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
+      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+    
+    if (Index_pos>=ListSize) then
+      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
+      stop
+    endif
+     
+    Pos=Buffer_Pos(Index_Pos)
+    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
+    Index_Pos=Index_Pos+1
+    Index=Index_Pos
+    
+  end subroutine allocate_buffer
+     
+  subroutine deallocate_buffer(Index)
+  implicit none
+    integer :: Index
+    
+    Buffer_Pos(Index)=-1
+    
+    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
+      Index_Pos=Index_Pos-1
+    end do
+
+  end subroutine deallocate_buffer  
+  
+  subroutine SetTag(a_request,tag)
+  implicit none
+    type(request):: a_request
+    integer :: tag
+    
+    a_request%tag=tag
+  end subroutine SetTag
+  
+  
+  subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo)
+    integer :: Stride
+    integer :: NbLevel
+    integer :: size
+    integer :: offset
+    real, dimension(Stride,NbLevel),target :: Field
+    type(Hallo) :: NewHallo
+    
+    NewHallo%Field=>Field
+    NewHallo%Stride=Stride
+    NewHallo%NbLevel=NbLevel
+    NewHallo%size=size
+    NewHallo%offset=offset
+    
+    
+  end subroutine Init_Hallo
+  
+  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
+  implicit none
+
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestSend(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif      
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+      
+   end subroutine Register_SendField      
+      
+  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
+  implicit none
+
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestRecv(target)
+      Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+      
+      if (Ptr_Request%NbRequest>=MaxRequest) then
+        print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!'
+        stop
+      endif   
+            
+      call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest))
+
+      
+   end subroutine Register_RecvField      
+  
+  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapField    
+  
+  
+    subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
+      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
+    enddo
+   
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapFieldHallo
+  
+  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo
+    
+    subroutine SendRequest(a_Request)
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+      include 'mpif.h'
+
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer :: SizeBuffer
+      integer :: i,rank,l,ij,Pos,ierr
+      integer :: offset
+!      real,dimension(:),pointer :: Buffer
+      real,dimension(:,:),pointer :: Field
+      integer :: Nb
+       
+      do rank=0,MPI_SIZE-1
+      
+        Req=>a_Request%RequestSend(rank)
+        
+        SizeBuffer=0
+        do i=1,Req%NbRequest
+          PtrHallo=>Req%Hallo(i)
+          SizeBuffer=SizeBuffer+PtrHallo%size*PtrHallo%NbLevel*iip1
+        enddo
+      
+        if (SizeBuffer>0) then
+       
+!          allocate(Req%Buffer(SizeBuffer))
+          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
+
+          Pos=Req%Pos
+!          Buffer=>req%Buffer
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+            Nb=iip1*PtrHallo%size-1
+            Field=>PtrHallo%Field
+            
+            do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        Buffer(Pos+ij)=Field(Offset+ij,l)
+	      enddo
+!              Buffer(Pos:Pos+Nb)=Field(offset:offset+Nb,l)
+              
+              Pos=Pos+Nb+1
+            enddo
+            
+          enddo
+    
+!         print *, 'process',MPI_RANK,'ISSEND: requette ',a_request%tag,'au process',rank,'de taille',SizeBuffer
+!         call MPI_ISSEND(Req%Buffer,SizeBuffer,MPI_REAL8,rank,a_request%tag,     &
+!                         COMM_LMDZ,Req%MSG_Request,ierr)
+         call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL8,rank,a_request%tag,     &
+                         COMM_LMDZ,Req%MSG_Request,ierr)
+
+        endif
+
+    enddo
+   
+           
+      do rank=0,MPI_SIZE-1
+         
+          Req=>a_Request%RequestRecv(rank)
+          SizeBuffer=0
+          
+	  do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            SizeBuffer=SizeBuffer+PtrHallo%size*PtrHallo%NbLevel*iip1
+          enddo
+        
+          if (SizeBuffer>0) then
+!            allocate(Req%Buffer(SizeBuffer))
+             call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
+!            print *, 'process',MPI_RANK,'IRECV: requette ',a_request%tag,'au process',rank,'de taille',SizeBuffer
+            
+!	    call MPI_IRECV(Req%Buffer,SizeBuffer,MPI_REAL8,rank,a_request%tag,     &
+!                           COMM_LMDZ,Req%MSG_Request,ierr)
+	    call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL8,rank,a_request%tag,     &
+                           COMM_LMDZ,Req%MSG_Request,ierr)
+
+          endif
+      
+      enddo
+                        
+   end subroutine SendRequest 
+   
+   subroutine WaitRequest(a_Request)
+   implicit none
+   
+#include "dimensions.h"
+#include "paramet.h"
+      include 'mpif.h'   
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(2*mpi_size) :: TabRequest
+      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      integer :: Nb
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      if (NbRequest>0) call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+!              PtrHallo%Field(offset:offset+Nb,l)=Buffer(Pos:Pos+Nb)
+!	      do ij=offset,offset+iip1*PtrHallo%size-1
+!                PtrHallo%Field(ij,l)=Buffer(Pos)
+!                Pos=Pos+1
+!              enddo
+              Pos=Pos+Nb+1
+	    enddo
+	    
+          enddo
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRequest
+     
+   subroutine WaitSendRequest(a_Request)
+   implicit none
+   
+#include "dimensions.h"
+#include "paramet.h"
+      include 'mpif.h'   
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+
+      if (NbRequest>0) call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+      
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      a_request%tag=1
+    end subroutine WaitSendRequest
+    
+   subroutine WaitRecvRequest(a_Request)
+   implicit none
+   
+#include "dimensions.h"
+#include "paramet.h"
+      include 'mpif.h'   
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset,Nb
+      
+      
+      NbRequest=0
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      
+      if (NbRequest>0) call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+                 Pos=Pos+Nb+1
+            enddo
+          enddo
+        endif
+      enddo
+      
+           
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRecvRequest
+    
+    
+    
+    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb,ijb,ije
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
+    jje=min(jj_end,jj_end_new(MPI_Rank))
+    if (ij==ip1jm) jje=min(jje,jjm)
+
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+      FieldR(ijb:ije,1:ll)=FieldS(ijb:ije,1:ll)
+    endif
+
+  end subroutine CopyField    
+
+  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
+  
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+
+    integer ::i,jje,jjb,ijb,ije
+
+     
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+
+        
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
+    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
+    if (ij==ip1jm) jje=min(jje,jjm)
+    
+    
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+      FieldR(ijb:ije,1:ll)=FieldS(ijb:ije,1:ll)
+    endif
+   end subroutine CopyFieldHallo        
+          
+end module mod_Hallo 
+   
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_interface_dyn_phys.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_interface_dyn_phys.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/mod_interface_dyn_phys.F90	(revision 984)
@@ -0,0 +1,52 @@
+MODULE mod_interface_dyn_phys
+  INTEGER,SAVE,dimension(:),allocatable :: index_i
+  INTEGER,SAVE,dimension(:),allocatable :: index_j
+  
+  
+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 
+
+END MODULE mod_interface_dyn_phys
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrad (klevel, rot, x, y )
+c
+c     P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_gam.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_gam.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_gam.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrad_gam( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_gam_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_gam_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_gam_p.F	(revision 984)
@@ -0,0 +1,67 @@
+      SUBROUTINE nxgrad_gam_p( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+      integer ismin,ismax
+      external ismin,ismax
+      INTEGER :: ijb,ije
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      if(pole_nord) ijb=ij_begin+iip1
+      if(pole_sud) ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+    
+      if (pole_nord) then
+        DO  ij = 1,iip1
+         x(    ij    ,l ) = 0.
+        ENDDO
+      endif
+
+      if (pole_sud) then
+        DO  ij = 1,iip1
+         x( ij +ip1jm,l ) = 0.
+        ENDDO
+      endif
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrad_p.F	(revision 984)
@@ -0,0 +1,67 @@
+      SUBROUTINE nxgrad_p (klevel, rot, x, y )
+c
+c     P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+      INTEGER :: ijb,ije
+c
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 10 l = 1,klevel
+c
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_sud)  ije=ij_end-iip1
+       
+      DO 1  ij = ijb+1, ije
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = ijb, ije, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_nord)  ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO 4  ij = ijb,ije
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+   
+      if (pole_nord) then 
+        DO ij = 1,iip1
+          x(    ij    ,l ) = 0.
+        ENDDO
+      endif
+      
+      if (pole_sud) then 
+        DO ij = 1,iip1
+          x( ij +ip1jm,l ) = 0.
+        ENDDO
+      endif
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgradst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgradst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgradst.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgradst (klevel,rot, x, y )
+c
+      IMPLICIT NONE
+c     Auteur :  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y(ij,l)=( rot(ij,l) - rot(ij-1,l))
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgraro2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgraro2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgraro2.F	(revision 984)
@@ -0,0 +1,68 @@
+!
+! $Header$
+!
+       SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
+c
+c      P.Le Van .
+c   ***********************************************************
+c                                 lr
+c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+c
+c    ......  variables en arguments  .......
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL rot(ip1jm,llm) , signe, nugradrs
+      INTEGER l,ij,iter,lr
+c    ........................................................
+c
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+c
+      CALL     rotatf     ( klevel, grx, gry, rot )
+c
+      CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
+
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+        CALL laplacien_rotgam ( klevel, rot, rot )
+      ENDDO
+c
+c
+      CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
+      CALL nxgrad ( klevel, rot, grx, gry )
+c
+      DO    l = 1, klevel
+         DO  ij = 1, ip1jm
+          gry( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+         DO  ij = 1, ip1jmp1
+          grx( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgraro2_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgraro2_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgraro2_p.F	(revision 984)
@@ -0,0 +1,141 @@
+       SUBROUTINE nxgraro2_p (klevel,xcov, ycov, lr, grx_out, gry_out )
+c
+c      P.Le Van .
+c   ***********************************************************
+c                                 lr
+c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      USE write_Field_p
+      USE parallel
+      USE times
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+c
+c    ......  variables en arguments  .......
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
+      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL,SAVE :: rot(ip1jm,llm)
+      REAL  signe, nugradrs
+      INTEGER l,ij,iter,lr
+c    ........................................................
+c
+      INTEGER :: ijb,ije,jjb,jje
+      
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+c      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+c      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+ 
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+        grx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP BARRIER
+c$OMP MASTER          
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(grx,ip1jmp1,llm,0,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO    l = 1, klevel
+        gry(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+ 
+c
+      CALL     rotatf_p     ( klevel, grx, gry, rot )
+c      call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/)))
+
+c$OMP BARRIER
+c$OMP MASTER      
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(rot,ip1jm,llm,1,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL laplacien_rot_p ( klevel, rot, rot,grx,gry      )
+c       call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/)))
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+c$OMP BARRIER
+c$OMP MASTER
+        call suspend_timer(timer_dissip)
+	call exchange_Hallo(rot,ip1jm,llm,1,1)
+        call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+	CALL laplacien_rotgam_p ( klevel, rot, rot )
+      ENDDO
+      
+c       call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/)))
+      
+c
+c
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+       
+      CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2,1, .FALSE.,1)
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(rot,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      CALL nxgrad_p ( klevel, rot, grx, gry )
+
+c
+      ijb=ij_begin
+      ije=ij_end
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+      DO    l = 1, klevel
+        
+         if(pole_sud) ije=ij_end-iip1
+         DO  ij = ijb, ije
+          gry_out( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+        
+         if(pole_sud) ije=ij_end
+         DO  ij = ijb, ije
+          grx_out( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+     
+      ENDDO
+c$OMP END DO NOWAIT
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrarot.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrarot.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrarot.F	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+      SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
+c   ***********************************************************
+c
+c    Auteur :  P.Le Van  
+c
+c                                 lr
+c      calcul de  ( nXgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+      REAL rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      DO 10 iter = 1,lr
+      CALL  rotat (klevel,grx, gry, rot )
+      CALL filtreg( rot, jjm, klevel, 2,1, .false.,2)
+      CALL nxgrad (klevel,rot, grx, gry )
+c
+      DO 5  l = 1, klevel
+      DO 2 ij = 1, ip1jm
+      gry( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      DO 3 ij = 1, ip1jmp1
+      grx( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrarot_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrarot_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/nxgrarot_p.F	(revision 984)
@@ -0,0 +1,101 @@
+      SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out )
+c   ***********************************************************
+c
+c    Auteur :  P.Le Van  
+c
+c                                 lr
+c      calcul de  ( nXgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      USE parallel
+      USE times
+      USE write_field_p
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx_out( ip1jmp1,klevel ),  gry_out( ip1jm,klevel )
+      REAL,SAVE ::  grx( ip1jmp1,llm ),  gry( ip1jm,llm )
+
+c
+      REAL,SAVE :: rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+      INTEGER ijb,ije,jjb,jje
+c
+c
+c      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+c      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      ijb=ij_begin
+      ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+      DO l = 1, klevel
+        grx(ijb:ije,l)=xcov(ijb:ije,l)
+      ENDDO 
+c$OMP END DO NOWAIT      
+
+      if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, klevel
+        gry(ijb:ije,l)=ycov(ijb:ije,l)
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      DO 10 iter = 1,lr
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(grx,ip1jmp1,llm,0,1)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+
+      CALL  rotat_p (klevel,grx, gry, rot )
+c      call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/)))
+      
+      jjb=jj_begin
+      jje=jj_end
+      if (pole_sud) jje=jj_end-1
+      CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2)
+
+c$OMP BARRIER
+c$OMP MASTER
+      call suspend_timer(timer_dissip)
+      call exchange_Hallo(rot,ip1jm,llm,1,0)
+      call resume_timer(timer_dissip)
+c$OMP END MASTER
+c$OMP BARRIER
+      
+      CALL nxgrad_p (klevel,rot, grx, gry )
+c
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5  l = 1, klevel
+      if(pole_sud) ije=ij_end-iip1
+      DO 2 ij = ijb, ije
+      gry_out( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      if(pole_sud) ije=ij_end
+      DO 3 ij = ijb, ije
+      grx_out( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c$OMP END DO NOWAIT
+c      call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/)))
+c      call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/)))
+c      stop
+  10  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/omp_chunk.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/omp_chunk.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/omp_chunk.h	(revision 984)
@@ -0,0 +1,1 @@
+#define OMP_CHUNK 5
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ord_coord.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ord_coord.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ord_coord.F	(revision 984)
@@ -0,0 +1,95 @@
+!
+! $Header$
+!
+       SUBROUTINE ord_coord ( nmax, xi, xo, decrois )
+
+c   .... Auteur :  P. Le Van  .... 
+c
+c   ... Reordonne eventuellement les coordonnees de la grille donnees ...
+c
+       IMPLICIT NONE
+
+c    .....  Arguments  en entree  .....
+
+       INTEGER nmax
+       REAL xi(nmax)
+
+c    .....  Arguments  en sortie  .....
+c
+       REAL xo(nmax+1) 
+       LOGICAL decrois
+
+c    .... Variables  locales  ....
+
+       REAL xscr(nmax)
+       INTEGER i,ii
+       REAL pi, degres, chmin, chmax, mult
+c
+
+       pi     = 2.*ASIN(1.)
+       degres = 180./pi
+       decrois = .FALSE.
+
+       DO i = 1, nmax 
+        xo(i) = xi(i)
+       ENDDO
+     
+       mult = 1.
+       IF( xo(1).GT.xo(nmax) ) mult = -1.
+
+       CALL minmax(nmax,xo(1),chmin,chmax)
+
+       IF(chmax.LT.6.5 )  THEN
+          DO i = 1,nmax
+           xo(i) = xo(i) * degres 
+          ENDDO
+       ENDIF
+
+       IF( ABS( xo( 1  ) + mult* 90. ). LT .0.001. OR .
+     ,     ABS( xo(nmax) - mult* 90. ). LT .0.001      )  THEN
+        PRINT *,' Reverifier les valeurs de  xidat  pour les donnees .'
+        PRINT *,' Elles doivent correspondre aux interfaces et non aux',
+     , 'ordonnees des donnees,egales a -90. et 90.deg aux 2 extremites '
+         CALL ABORT
+       ENDIF
+
+       IF( xo(1).GT.xo(nmax) )   THEN
+          DO i = 1, nmax 
+            xscr(i) = xo(i)
+          ENDDO
+          DO i = 1, nmax 
+            xo(i+1) = xscr(i)
+          ENDDO
+            xo (   1    ) =   90.
+       ELSE
+            xo ( nmax +1) =   90.
+       ENDIF
+
+       IF ( xo(2).LT.xo(1) ) decrois =.TRUE.
+
+       DO i = 3, nmax 
+
+        IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN
+         PRINT 1
+         PRINT 2,(xo(ii),ii=1,nmax)
+         CALL ABORT 
+        ENDIF
+        IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN
+         PRINT 1
+         PRINT 2,(xo(ii),ii=1,nmax)
+         CALL ABORT
+        ENDIF
+
+       ENDDO
+        
+       IF( decrois )  THEN
+c         CALL sort(nmax+1,xo(1))
+        CALL sort(nmax+1,xo)
+       ENDIF
+
+1      FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ',
+     ,  'grille du modele ')
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ord_coordm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ord_coordm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ord_coordm.F	(revision 984)
@@ -0,0 +1,110 @@
+!
+! $Header$
+!
+       SUBROUTINE ord_coordm ( nmax, xi, xo, jjm, jmods, decrois )
+
+c   ....  Auteur :  P. Le Van  .... 
+
+c   ... Reordonne eventuellement les coordonnees de la grille modele ...
+c
+       IMPLICIT NONE
+
+c    .....  Arguments  en entree  .....
+
+       INTEGER nmax,jjm
+       REAL xi(nmax)
+
+c    .....  Arguments  en sortie  .....
+c
+       REAL xo(nmax+1) 
+       LOGICAL decrois
+       INTEGER jmods
+
+c    .... Variables  locales  ....
+
+       REAL xscr(nmax)
+       INTEGER i
+       REAL pi, degres, chmin, chmax,mult
+c
+       DO i = 1, nmax 
+        xo(i) = xi(i)
+       ENDDO
+
+       mult = 1.
+       IF( xo(1).GT.xo(nmax) )  mult = - 1.
+       IF( nmax.EQ.jjm    ) jmods = nmax +1
+       IF( nmax.EQ.jjm +1 ) jmods = nmax -1 
+     
+       pi     = 2.*ASIN(1.)
+       degres = 180./pi
+       decrois = .FALSE.
+
+       CALL minmax(nmax,xo(1),chmin,chmax)
+
+       IF(chmax.LT.6.5 )  THEN
+          DO i = 1,nmax
+           xo(i) = xo(i) * degres 
+          ENDDO
+       ENDIF
+
+       IF( nmax.EQ.jjm )   THEN
+         IF( xo(1).GT.xo(nmax) )   THEN
+           DO i = 1, nmax 
+            xscr(i) = xo(i)
+           ENDDO
+           DO i = 1, nmax 
+            xo(i+1) = xscr(i)
+           ENDDO
+            xo (   1    ) =   90.
+         ELSE
+            xo ( nmax+1 ) =   90.
+         ENDIF
+       ELSE
+          IF( nmax.NE.jjm +1 )   THEN
+             PRINT *,'  Dans la routine ord_coordm , l argument nmax '
+             PRINT *,'  n est pas egal a jjm ni a jjm +1 . Corriger !'
+             CALL ABORT
+          ELSE
+            IF( ABS( xo(1)+ mult * 90.).GT.0.01 )  THEN
+              PRINT *,' Avec nmax =',nmax,'on devrait avoir des',
+     ,    ' ordonnees = 90. deg pour j=1 ou jjm+1 ! '
+             CALL ABORT
+            ELSE
+               IF( xo(1).LT.xo(nmax) )  THEN
+                 DO i = 1, nmax
+                  xscr(i) = xo(i)
+                 ENDDO
+                 DO i = 1, nmax -1
+                  xo(i) = xscr(i+1)
+                 ENDDO
+               ENDIF
+            ENDIF
+          ENDIF
+       ENDIF
+
+       IF ( xo(2).LT.xo(1) ) decrois =.TRUE.
+
+       DO i = 3, nmax 
+
+        IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN
+         PRINT 1
+         CALL ABORT 
+        ENDIF
+        IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN
+         PRINT 1
+         CALL ABORT
+        ENDIF
+
+       ENDDO
+        
+       IF( decrois )  THEN
+         CALL sort(jmods,xo(1))
+       ENDIF
+
+
+1      FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ',
+     ,  'grille du modele ')
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/parallel.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/parallel.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/parallel.F90	(revision 984)
@@ -0,0 +1,436 @@
+  module parallel
+  USE mod_const_mpi
+   
+    integer, save :: mpi_size
+    integer, save :: mpi_rank
+    integer, save :: jj_begin
+    integer, save :: jj_end
+    integer, save :: jj_nb
+    integer, save :: ij_begin
+    integer, save :: ij_end
+    logical, save :: pole_nord
+    logical, save :: pole_sud
+    
+    integer, allocatable, save, dimension(:) :: jj_begin_para
+    integer, allocatable, save, dimension(:) :: jj_end_para
+    integer, allocatable, save, dimension(:) :: jj_nb_para
+    integer, save :: OMP_CHUNK
+    
+ contains
+ 
+    subroutine init_parallel
+    USE vampir
+    implicit none
+    
+      integer :: ierr
+      integer :: i,j
+      integer :: type_size
+      integer, dimension(3) :: blocklen,type
+      
+      
+      include 'mpif.h'
+#include "dimensions.h"
+#include "paramet.h"
+
+      call InitVampir
+      call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
+      call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
+  
+      
+      allocate(jj_begin_para(0:mpi_size-1))
+      allocate(jj_end_para(0:mpi_size-1))
+      allocate(jj_nb_para(0:mpi_size-1))
+      
+      do i=0,mpi_size-1
+        jj_nb_para(i)=(jjm+1)/mpi_size
+        if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
+        
+        if (jj_nb_para(i) <= 2 ) then
+          
+         print *,"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
+          print *," ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
+          
+          call MPI_ABORT(COMM_LMDZ,-1, ierr)
+          
+        endif
+        
+      enddo
+      
+!      jj_nb_para(0)=11
+!      jj_nb_para(1)=25
+!      jj_nb_para(2)=25
+!      jj_nb_para(3)=12      
+
+      j=1
+      
+      do i=0,mpi_size-1 
+        
+        jj_begin_para(i)=j
+        jj_end_para(i)=j+jj_Nb_para(i)-1
+        j=j+jj_Nb_para(i)
+      
+      enddo
+      
+      jj_begin = jj_begin_para(mpi_rank)
+      jj_end   = jj_end_para(mpi_rank)
+      jj_nb    = jj_nb_para(mpi_rank)
+      
+      ij_begin=(jj_begin-1)*iip1+1
+      ij_end=jj_end*iip1
+      
+      if (mpi_rank.eq.0) then
+        pole_nord=.TRUE.
+      else 
+        pole_nord=.FALSE.
+      endif
+      
+      if (mpi_rank.eq.mpi_size-1) then
+        pole_sud=.TRUE.
+      else 
+        pole_sud=.FALSE.
+      endif
+        
+      print *,"jj_begin",jj_begin
+      print *,"jj_end",jj_end
+      print *,"ij_begin",ij_begin
+      print *,"ij_end",ij_end
+    
+    
+    end subroutine init_parallel
+
+    
+    subroutine SetDistrib(jj_Nb_New)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New
+      INTEGER :: i  
+  
+      jj_Nb_Para=jj_Nb_New
+      
+      jj_begin_para(0)=1
+      jj_end_para(0)=jj_Nb_Para(0)
+      
+      do i=1,mpi_size-1 
+        
+        jj_begin_para(i)=jj_end_para(i-1)+1
+        jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1
+      
+      enddo
+      
+      jj_begin = jj_begin_para(mpi_rank)
+      jj_end   = jj_end_para(mpi_rank)
+      jj_nb    = jj_nb_para(mpi_rank)
+      
+      ij_begin=(jj_begin-1)*iip1+1
+      ij_end=jj_end*iip1
+
+    end subroutine SetDistrib
+
+
+
+    
+    subroutine Finalize_parallel
+#ifdef CPP_COUPLE
+    use mod_prism_proto
+#endif
+      use surface_data, only : ocean
+      implicit none
+
+      include "dimensions.h"
+      include "paramet.h"
+      integer :: ierr
+      integer :: i
+      include 'mpif.h'
+      
+      deallocate(jj_begin_para)
+      deallocate(jj_end_para)
+      deallocate(jj_nb_para)
+
+      if (ocean == 'couple') then
+#ifdef CPP_COUPLE
+         call prism_terminate_proto(ierr)
+         IF (ierr .ne. PRISM_Ok) THEN
+            call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
+         endif
+#endif 
+      else
+         call MPI_FINALIZE(ierr)
+      end if
+      
+    end subroutine Finalize_parallel
+        
+    subroutine Pack_Data(Field,ij,ll,row,Buffer)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer, intent(in) :: ij,ll,row
+      real,dimension(ij,ll),intent(in) ::Field
+      real,dimension(ll*iip1*row), intent(out) :: Buffer 
+            
+      integer :: Pos
+      integer :: i,l
+      
+      Pos=0
+      do l=1,ll
+        do i=1,row*iip1
+          Pos=Pos+1
+          Buffer(Pos)=Field(i,l)
+        enddo
+      enddo
+      
+    end subroutine Pack_data 
+     
+    subroutine Unpack_Data(Field,ij,ll,row,Buffer)
+    implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer, intent(in) :: ij,ll,row
+      real,dimension(ij,ll),intent(out) ::Field
+      real,dimension(ll*iip1*row), intent(in) :: Buffer 
+            
+      integer :: Pos
+      integer :: i,l
+      
+      Pos=0
+      
+      do l=1,ll
+        do i=1,row*iip1
+          Pos=Pos+1
+          Field(i,l)=Buffer(Pos)
+        enddo
+      enddo
+      
+    end subroutine UnPack_data
+      
+    subroutine exchange_hallo(Field,ij,ll,up,down)
+    USE Vampir
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: up,down
+      
+      INTEGER :: ierr
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+      INTEGER, DIMENSION(4) :: Request
+      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
+      INTEGER :: NbRequest
+      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
+      REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
+      INTEGER :: Buffer_size      
+      
+      call MPI_Barrier(COMM_LMDZ,ierr)
+      call VTb(VThallo)
+      
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (up.eq.0) then
+        SendDown=.FALSE.
+        RecvUp=.FALSE.
+      endif
+      
+      if (down.eq.0) then
+        SendUp=.FALSE.
+        RecvDown=.FALSE.
+      endif
+      
+      NbRequest=0
+  
+      IF (SendUp) THEN
+        NbRequest=NbRequest+1
+        buffer_size=down*iip1*ll
+        allocate(Buffer_Send_up(Buffer_size))
+        call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
+        call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
+                        COMM_LMDZ,Request(NbRequest),ierr)
+      ENDIF
+  
+      IF (SendDown) THEN
+        NbRequest=NbRequest+1
+        
+        buffer_size=up*iip1*ll
+        allocate(Buffer_Send_down(Buffer_size))
+        call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
+        
+        call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
+                        COMM_LMDZ,Request(NbRequest),ierr)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        NbRequest=NbRequest+1
+        buffer_size=up*iip1*ll
+        allocate(Buffer_recv_up(Buffer_size))
+              
+        call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
+                        COMM_LMDZ,Request(NbRequest),ierr)
+     
+       
+      ENDIF
+  
+      IF (RecvDown) THEN
+        NbRequest=NbRequest+1
+        buffer_size=down*iip1*ll
+        allocate(Buffer_recv_down(Buffer_size))
+        
+        call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
+                        COMM_LMDZ,Request(NbRequest),ierr)
+      
+        
+      ENDIF
+  
+      if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
+      IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
+      IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down)  
+
+      call VTe(VThallo)
+      call MPI_Barrier(COMM_LMDZ,ierr)
+      RETURN
+      
+    end subroutine exchange_Hallo
+    
+    
+    subroutine Gather_Field(Field,ij,ll,rank)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll,rank
+      REAL, dimension(ij,ll) :: Field
+      REAL, dimension(:),allocatable :: Buffer_send   
+      REAL, dimension(:),allocatable :: Buffer_Recv
+      INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
+      INTEGER :: ierr
+      INTEGER ::i
+      
+      if (ij==ip1jmp1) then 
+         allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
+         call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
+      else if (ij==ip1jm) then
+         allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
+         call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
+      else
+         print *,ij
+	 stop 'erreur dans Gather_Field'
+      endif
+      
+      if (MPI_Rank==rank) then
+        allocate(Buffer_Recv(ij*ll))
+        do i=0,MPI_Size-1
+          
+          if (ij==ip1jmp1) then 
+            Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
+          else if (ij==ip1jm) then
+            Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
+          else
+            stop 'erreur dans Gather_Field'
+          endif
+          
+          if (i==0) then 
+            displ(i)=0 
+          else
+            displ(i)=displ(i-1)+Recv_count(i-1)
+          endif
+          
+        enddo
+        
+      endif
+      
+      call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
+                        Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
+      
+      if (MPI_Rank==rank) then                  
+      
+        if (ij==ip1jmp1) then 
+          do i=0,MPI_Size-1
+            call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
+                             jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
+          enddo
+        else if (ij==ip1jm) then
+          do i=0,MPI_Size-1
+             call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
+                             min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
+          enddo
+        endif
+      
+      endif
+      
+    end subroutine Gather_Field
+    
+    subroutine AllGather_Field(Field,ij,ll)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: ierr
+      
+      call Gather_Field(Field,ij,ll,0)
+      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
+      
+    end subroutine AllGather_Field
+    
+   subroutine Broadcast_Field(Field,ij,ll,rank)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: rank
+      INTEGER :: ierr
+      
+      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
+      
+    end subroutine Broadcast_Field
+        
+   
+    /*  
+  Subroutine verif_hallo(Field,ij,ll,up,down)
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"    
+    include 'mpif.h'
+    
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: up,down 
+      
+      REAL,dimension(ij,ll): NewField
+      
+      NewField=0
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) 
+      NewField(ij_be       
+*/
+  end module parallel
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/paramet.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/paramet.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/paramet.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3                &
+     &    ,jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/pbar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/pbar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/pbar.F	(revision 984)
@@ -0,0 +1,124 @@
+!
+! $Header$
+!
+      SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c *********************************************************************
+c
+c          pext               est  un argum. d'entree  pour le s-pg ..
+c     pbarx,pbary et pbarxy  sont des argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+
+#include "comgeom.h"
+
+      REAL pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
+      REAL pbary(  ip1jm  ),  pbarxy(  ip1jm  )
+
+      INTEGER   ij
+
+
+
+      DO 1 ij = 1, ip1jmp1 - 1
+      pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
+   1  CONTINUE
+
+c    .... correction pour pbarx( iip1,j) .....
+
+c    ...    pbarx(iip1,j)= pbarx(1,j) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jmp1, iip1
+      pbarx( ij ) = pbarx( ij - iim )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     +
+     *              pext( ij+iip1 ) * alpha1p4( ij+iip1 )
+   3  CONTINUE
+
+
+      DO 5 ij = 1, ip1jm - 1
+      pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     pbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      pbarxy( ij ) = pbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/pentes_ini.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/pentes_ini.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/pentes_ini.F	(revision 984)
@@ -0,0 +1,474 @@
+!
+! $Header$
+!
+      SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode)
+      IMPLICIT NONE
+
+c=======================================================================
+c   Adaptation LMDZ:  A.Armengaud (LGGE)
+c   ----------------
+c
+c   ********************************************************************
+c   Transport des traceurs par la methode des pentes
+c   ********************************************************************
+c   Reference possible : Russel. G.L., Lerner J.A.:
+c         A new Finite-Differencing Scheme for Traceur Transport 
+c         Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 
+c   ********************************************************************
+c   q,w,masse,pbaru et pbarv 
+c                      sont des arguments d'entree  pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c   Arguments:
+c   ----------
+      integer mode
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL q( iip1,jjp1,llm,0:3)
+      REAL w( ip1jmp1,llm )
+      REAL masse( iip1,jjp1,llm)
+c   Local:
+c   ------
+      LOGICAL limit
+      REAL sm ( iip1,jjp1, llm )
+      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+      real masn,mass,zz
+      INTEGER i,j,l,iq
+
+c  modif Fred 24 03 96
+
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      save sinlon,coslon,sinlondlon,coslondlon
+      real dyn1,dyn2,dys1,dys2
+      real qpn,qps,dqzpn,dqzps
+      real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1)
+      real qmin,zq,pente_max
+c
+      REAL      SSUM
+      integer ismax,ismin,lati,latf
+      EXTERNAL  SSUM, ismin,ismax
+      logical first
+      save first
+c   fin modif
+
+
+c  modif Fred 24 03 96
+      data first/.true./
+
+      limit = .TRUE.
+      pente_max=2
+c     if (mode.eq.1.or.mode.eq.3) then
+c     if (mode.eq.1) then
+      if (mode.ge.1) then
+        lati=2
+        latf=jjm
+      else
+        lati=1
+        latf=jjp1
+      endif
+
+      qmin=0.4995
+      qmin=0.
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+            print*,coslondlon(i),sinlondlon(i)
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1)
+         print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1)
+        DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+         q ( i,j,l,1 )=0.
+         q ( i,j,l,2 )=0.
+         q ( i,j,l,3 )=0.  
+         ENDDO
+         ENDDO
+        ENDDO
+        
+      endif
+c   Fin modif Fred
+
+c *** q contient les qqtes de traceur avant l'advection 
+
+c *** Affectation des tableaux S a partir de Q
+c *** Rem : utilisation de SCOPY ulterieurement
+ 
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+             s0( i,j,llm+1-l ) = q ( i,j,l,0 )
+             sx( i,j,llm+1-l ) = q ( i,j,l,1 )
+             sy( i,j,llm+1-l ) = q ( i,j,l,2 )
+             sz( i,j,llm+1-l ) = q ( i,j,l,3 )
+         ENDDO
+        ENDDO
+       ENDDO
+
+c      PRINT*,'----- S0 just before conversion -------'
+c      PRINT*,'S0(16,12,1)=',s0(16,12,1) 
+c      PRINT*,'Q(16,12,1,4)=',q(16,12,1,4)
+
+c *** On calcule la masse d'air en kg
+
+       DO  l = 1,llm
+         DO  j = 1,jjp1
+           DO  i = 1,iip1
+            sm ( i,j,llm+1-l)=masse( i,j,l )
+          ENDDO
+         ENDDO
+       ENDDO
+
+c *** On converti les champs S en atome (resp. kg) 
+c *** Les routines d'advection traitent les champs
+c *** a advecter si ces derniers sont en atome (resp. kg)
+c *** A optimiser !!!
+
+       DO  l = 1,llm
+         DO  j = 1,jjp1
+           DO  i = 1,iip1
+               s0(i,j,l) = s0(i,j,l) * sm ( i,j,l )
+               sx(i,j,l) = sx(i,j,l) * sm ( i,j,l )
+               sy(i,j,l) = sy(i,j,l) * sm ( i,j,l )
+               sz(i,j,l) = sz(i,j,l) * sm ( i,j,l )
+           ENDDO
+         ENDDO
+       ENDDO
+
+c       ss0 = 0.
+c       DO l = 1,llm
+c        DO j = 1,jjp1
+c         DO i = 1,iim
+c            ss0 = ss0 + s0 ( i,j,l )
+c         ENDDO
+c        ENDDO
+c       ENDDO
+c       PRINT*, 'valeur tot s0 avant advection=',ss0
+
+c *** Appel des subroutines d'advection en X, en Y et en Z
+c *** Advection avec "time-splitting"
+      
+c-----------------------------------------------------------
+c      PRINT*,'----- S0 just before ADVX -------'
+c      PRINT*,'S0(16,12,1)=',s0(16,12,1)
+
+c-----------------------------------------------------------
+c      do l=1,llm
+c         do j=1,jjp1
+c          do i=1,iip1
+c             zq=s0(i,j,l)/sm(i,j,l)
+c            if(zq.lt.qmin)
+c    ,       print*,'avant advx1, s0(',i,',',j,',',l,')=',zq
+c          enddo
+c         enddo
+c      enddo
+CCC
+       if(mode.eq.2) then
+          do l=1,llm
+            s0s=0.
+            s0n=0.
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            smn=0.
+            sms=0.
+            do i=1,iim
+               smn=smn+sm(i,1,l)
+               sms=sms+sm(i,jjp1,l)
+               s0n=s0n+s0(i,1,l)
+               s0s=s0s+s0(i,jjp1,l)
+               zz=sy(i,1,l)/sm(i,1,l)
+               dyn1=dyn1+sinlondlon(i)*zz
+               dyn2=dyn2+coslondlon(i)*zz
+               zz=sy(i,jjp1,l)/sm(i,jjp1,l)
+               dys1=dys1+sinlondlon(i)*zz
+               dys2=dys2+coslondlon(i)*zz
+            enddo
+            do i=1,iim
+               sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i)
+               sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i)
+            enddo
+            do i=1,iim
+               s0(i,1,l)=s0n/smn+sy(i,1,l)
+               s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l)
+            enddo
+
+            s0(iip1,1,l)=s0(1,1,l)
+            s0(iip1,jjp1,l)=s0(1,jjp1,l)
+
+            do i=1,iim
+               sxn(i)=s0(i+1,1,l)-s0(i,1,l)
+               sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l)
+c   on rerentre les masses
+            enddo
+            do i=1,iim
+               sy(i,1,l)=sy(i,1,l)*sm(i,1,l)
+               sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l)
+               s0(i,1,l)=s0(i,1,l)*sm(i,1,l)
+               s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l)
+            enddo
+            sxn(iip1)=sxn(1)
+            sxs(iip1)=sxs(1)
+            do i=1,iim
+               sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l)
+               sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l)
+            enddo
+            s0(iip1,1,l)=s0(1,1,l)
+            s0(iip1,jjp1,l)=s0(1,jjp1,l)
+            sy(iip1,1,l)=sy(1,1,l)
+            sy(iip1,jjp1,l)=sy(1,jjp1,l)
+            sx(1,1,l)=sx(iip1,1,l)
+            sx(1,jjp1,l)=sx(iip1,jjp1,l)
+          enddo
+      endif
+
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+      call limx(s0,sx,sm,pente_max)
+c     call minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+       call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf)
+c     call minmaxq(zq,1.e33,-1.e33,'avant advy     ')
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+       call   limy(s0,sy,sm,pente_max)
+       call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) 
+c     call minmaxq(zq,1.e33,-1.e33,'avant advz     ')
+       do j=1,jjp1
+          do i=1,iip1
+             sz(i,j,1)=0.
+             sz(i,j,llm)=0.
+          enddo
+       enddo
+       call limz(s0,sz,sm,pente_max)
+       call advz( limit,dtvr,w,sm,s0,sx,sy,sz )
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+        call limy(s0,sy,sm,pente_max)
+       call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) 
+       do l=1,llm
+          do j=1,jjp1
+             sm(iip1,j,l)=sm(1,j,l)
+             s0(iip1,j,l)=s0(1,j,l)
+             sx(iip1,j,l)=sx(1,j,l)
+             sy(iip1,j,l)=sy(1,j,l)
+             sz(iip1,j,l)=sz(1,j,l)
+          enddo
+       enddo
+
+
+c     call minmaxq(zq,1.e33,-1.e33,'avant advx     ')
+      if (mode.eq.4) then
+         do l=1,llm
+            do i=1,iip1
+               sx(i,1,l)=0.
+               sx(i,jjp1,l)=0.
+               sy(i,1,l)=0.
+               sy(i,jjp1,l)=0.
+            enddo
+         enddo
+      endif
+       call limx(s0,sx,sm,pente_max)
+       call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) 
+c     call minmaxq(zq,1.e33,-1.e33,'apres advx     ')
+c      do l=1,llm
+c         do j=1,jjp1
+c          do i=1,iip1
+c             zq=s0(i,j,l)/sm(i,j,l)
+c            if(zq.lt.qmin)
+c    ,       print*,'apres advx2, s0(',i,',',j,',',l,')=',zq
+c          enddo
+c         enddo
+c      enddo
+c ***   On repasse les S dans la variable q directement 14/10/94
+c   On revient a des rapports de melange en divisant par la masse
+
+c En dehors des poles:
+
+       DO  l = 1,llm
+        DO  j = 1,jjp1
+         DO  i = 1,iim
+             q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l)
+             q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l)
+         ENDDO
+        ENDDO
+      ENDDO
+
+c Traitements specifiques au pole
+
+      if(mode.ge.1) then
+      DO l=1,llm
+c   filtrages aux poles
+         masn=ssum(iim,sm(1,1,l),1)
+         mass=ssum(iim,sm(1,jjp1,l),1)
+         qpn=ssum(iim,s0(1,1,l),1)/masn
+         qps=ssum(iim,s0(1,jjp1,l),1)/mass
+         dqzpn=ssum(iim,sz(1,1,l),1)/masn
+         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+         do i=1,iip1
+            q( i,1,llm+1-l,3)=dqzpn
+            q( i,jjp1,llm+1-l,3)=dqzps
+            q( i,1,llm+1-l,0)=qpn
+            q( i,jjp1,llm+1-l,0)=qps
+         enddo
+         if(mode.eq.3) then
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            do i=1,iim
+               dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l)
+               dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l)
+               dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+               dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l)
+            enddo
+            do i=1,iim
+               q(i,1,llm+1-l,2)=
+     s          (sinlon(i)*dyn1+coslon(i)*dyn2)
+               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+               q(i,jjp1,llm+1-l,2)=
+     s          (sinlon(i)*dys1+coslon(i)*dys2)
+               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     s         -q(i,jjp1,llm+1-l,2)
+            enddo
+         endif
+         if(mode.eq.1) then
+c   on filtre les valeurs au bord de la "grande maille pole"
+            dyn1=0.
+            dys1=0.
+            dyn2=0.
+            dys2=0.
+            do i=1,iim
+               zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+               dyn1=dyn1+sinlondlon(i)*zz
+               dyn2=dyn2+coslondlon(i)*zz
+               zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+               dys1=dys1+sinlondlon(i)*zz
+               dys2=dys2+coslondlon(i)*zz
+            enddo
+            do i=1,iim
+               q(i,1,llm+1-l,2)=
+     s          (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+               q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2)
+               q(i,jjp1,llm+1-l,2)=
+     s          (sinlon(i)*dys1+coslon(i)*dys2)/2.
+               q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     s         -q(i,jjp1,llm+1-l,2)
+            enddo
+            q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+            q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+
+            do i=1,iim
+               sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+               sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+            enddo
+            sxn(iip1)=sxn(1)
+            sxs(iip1)=sxs(1)
+            do i=1,iim
+               q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+               q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+            enddo
+            q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+            q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1)
+
+         endif
+
+       ENDDO
+       endif
+
+c bouclage en longitude
+      do iq=0,3
+         do l=1,llm
+            do j=1,jjp1
+               q(iip1,j,l,iq)=q(1,j,l,iq)
+            enddo
+         enddo
+      enddo
+
+c       PRINT*, ' SORTIE DE PENTES ---  ca peut glisser ....'
+
+        DO l = 1,llm
+    	 DO j = 1,jjp1
+    	  DO i = 1,iip1
+                IF (q(i,j,l,0).lt.0.)  THEN
+c                    PRINT*,'------------ BIP-----------' 
+c                    PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0)
+c                    PRINT*,'QX(',i,j,l,')=',q(i,j,l,1)
+c                    PRINT*,'QY(',i,j,l,')=',q(i,j,l,2)
+c                    PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3)
+c       		     PRINT*,' PBL EN SORTIE DE PENTES'
+                     q(i,j,l,0)=0.
+c                    STOP
+                 ENDIF
+          ENDDO
+         ENDDO
+        ENDDO
+
+c       PRINT*, '-------------------------------------------'
+        
+       do l=1,llm
+          do j=1,jjp1
+           do i=1,iip1
+             if(q(i,j,l,0).lt.qmin)
+     ,       print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0)
+           enddo
+          enddo
+       enddo
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ppm3d.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ppm3d.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ppm3d.F	(revision 984)
@@ -0,0 +1,2001 @@
+!
+! $Header$
+!
+
+cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998
+cDate: Wed, 15 Apr 1998 11:37:03 -0400
+cFrom: lin@explorer.gsfc.nasa.gov
+cTo: Frederic.Hourdin@lmd.jussieu.fr
+cSubject: 3D transport module of the GSFC CTM and GEOS GCM
+
+
+cThis code is sent to you by S-J Lin, DAO, NASA-GSFC
+
+cNote: this version is intended for machines like CRAY
+C-90. No multitasking directives implemented.
+
+      
+C ********************************************************************
+C
+C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard
+C Earth Observing System General Circulation Model (GEOS-GCM), and Data
+C Assimilation System (GEOS-DAS).
+C
+C ********************************************************************
+C
+C Purpose: given horizontal winds on  a hybrid sigma-p surfaces,
+C          one call to tpcore updates the 3-D mixing ratio
+C          fields one time step (NDT). [vertical mass flux is computed
+C          internally consistent with the discretized hydrostatic mass
+C          continuity equation of the C-Grid GEOS-GCM (for IGD=1)].
+C
+C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based
+C          on the van Leer or PPM.
+C          (see Lin and Rood 1996).
+C Version 4.5
+C Last modified: Dec. 5, 1996
+C Major changes from version 4.0: a more general vertical hybrid sigma-
+C pressure coordinate.
+C Subroutines modified: xtp, ytp, fzppm, qckxyz
+C Subroutines deleted: vanz
+C
+C Author: Shian-Jiann Lin
+C mail address:
+C                 Shian-Jiann Lin*
+C                 Code 910.3, NASA/GSFC, Greenbelt, MD 20771
+C                 Phone: 301-286-9540
+C                 E-mail: lin@dao.gsfc.nasa.gov
+C
+C *affiliation:
+C                 Joint Center for Earth Systems Technology
+C                 The University of Maryland Baltimore County
+C                 NASA - Goddard Space Flight Center
+C References:
+C
+C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi-
+C    Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070.
+C
+C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of
+C    the van Leer-type transport schemes and its applications to the moist-
+C    ure transport in a General Circulation Model. Mon. Wea. Rev., 122,
+C    1575-1593.
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR,
+     &                  JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax)
+
+c      implicit none
+
+c     rajout de déclarations
+c      integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd
+c      integer iu,iiu,j2,jmr,js0,jt
+c      real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp
+c      real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru
+C
+C ********************************************************************
+C
+C =============
+C INPUT:
+C =============
+C
+C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t)
+C NC: total # of constituents
+C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR
+C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1
+C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at
+C       the model top to NLAY near the surface (see fig. below).
+C       It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation)
+C
+C PS1(IMR,JNP): surface pressure at current time (t)
+C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2)
+C PS2 is replaced by the predicted PS (at t+NDT) on output.
+C Note: surface pressure can have any unit or can be multiplied by any
+C       const.
+C
+C The pressure at layer edges are defined as follows:
+C
+C        p(i,j,k) = AP(k)*PT  +  BP(k)*PS(i,j)          (1)
+C
+C Where PT is a constant having the same unit as PS.
+C AP and BP are unitless constants given at layer edges
+C defining the vertical coordinate. 
+C BP(1) = 0., BP(NLAY+1) = 1.
+C The pressure at the model top is PTOP = AP(1)*PT
+C
+C For pure sigma system set AP(k) = 1 for all k, PT = PTOP,
+C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP.
+C
+C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn
+C is a subset of the following even more general sigma-P-thelta coord.
+C currently under development.
+C  p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa))
+C
+C                  /////////////////////////////////
+C              / \ ------------- PTOP --------------  AP(1), BP(1)
+C               |
+C    delp(1)    |  ........... Q(i,j,1) ............  
+C               |
+C      W(1)    \ / ---------------------------------  AP(2), BP(2)
+C
+C
+C
+C     W(k-1)   / \ ---------------------------------  AP(k), BP(k)
+C               |
+C    delp(K)    |  ........... Q(i,j,k) ............ 
+C               |
+C      W(k)    \ / ---------------------------------  AP(k+1), BP(k+1)
+C
+C
+C
+C              / \ ---------------------------------  AP(NLAY), BP(NLAY)
+C               |
+C  delp(NLAY)   |  ........... Q(i,j,NLAY) .........  
+C               |
+C   W(NLAY)=0  \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1)
+C                 //////////////////////////////////
+C
+C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2)
+C U and V may need to be polar filtered in advance in some cases.
+C 
+C IGD:      grid type on which winds are defined.
+C IGD = 0:  A-Grid  [all variables defined at the same point from south
+C                   pole (j=1) to north pole (j=JNP) ]
+C
+C IGD = 1  GEOS-GCM C-Grid
+C                                      [North]
+C
+C                                       V(i,j)
+C                                          |
+C                                          |
+C                                          |
+C                             U(i-1,j)---Q(i,j)---U(i,j) [EAST]
+C                                          |
+C                                          |
+C                                          |
+C                                       V(i,j-1)
+C
+C         U(i,  1) is defined at South Pole.
+C         V(i,  1) is half grid north of the South Pole.
+C         V(i,JMR) is half grid south of the North Pole.
+C
+C         V must be defined at j=1 and j=JMR if IGD=1
+C         V at JNP need not be given.
+C
+C NDT: time step in seconds (need not be constant during the course of
+C      the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5
+C      (Lat-Lon) resolution. Smaller values are recommanded if the model
+C      has a well-resolved stratosphere.
+C
+C J1 defines the size of the polar cap:
+C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg.
+C North polar cap edge is located at  90 - (j1-1.5)*180/(JNP-1) deg.
+C There are currently only two choices (j1=2 or 3).
+C IMR must be an even integer if j1 = 2. Recommended value: J1=3.
+C
+C IORD, JORD, and KORD are integers controlling various options in E-W, N-S,
+C and vertical transport, respectively. Recommended values for positive
+C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non-
+C positive definite scalars or when linear correlation between constituents
+C is to be maintained.
+C
+C  _ORD= 
+C        1: 1st order upstream scheme (too diffusive, not a useful option; it
+C           can be used for debugging purposes; this is THE only known "linear"
+C           monotonic advection scheme.).
+C        2: 2nd order van Leer (full monotonicity constraint;
+C           see Lin et al 1994, MWR)
+C        3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984)
+C        4: semi-monotonic PPM (same as 3, but overshoots are allowed)
+C        5: positive-definite PPM (constraint on the subgrid distribution is
+C           only strong enough to prevent generation of negative values;
+C           both overshoots & undershoots are possible).
+C        6: un-constrained PPM (nearly diffusion free; slightly faster but
+C           positivity not quaranteed. Use this option only when the fields
+C           and winds are very smooth).
+C
+C *PPM: Piece-wise Parabolic Method
+C
+C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5.
+C for non-positive definite scalars (such as Ertel Potential Vorticity).
+C
+C The implicit numerical diffusion decreases as _ORD increases.
+C The last two options (ORDER=5, 6) should only be used when there is
+C significant explicit diffusion (such as a turbulence parameterization). You
+C might get dispersive results otherwise.
+C No filter of any kind is applied to the constituent fields here.
+C
+C AE: Radius of the sphere (meters).
+C     Recommended value for the planet earth: 6.371E6
+C
+C fill(logical):   flag to do filling for negatives (see note below).
+C
+C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s).
+C (220 m/s is a good value for troposphere model; 280 m/s otherwise)
+C
+C =============
+C Output
+C =============
+C
+C Q: mixing ratios at future time (t+NDT) (original values are over-written)
+C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic
+C          relationship. W will have the same unit as PS1 and PS2 (eg, mb).
+C          W must be divided by NDT to get the correct mass-flux unit.
+C          The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND
+C          is the pressure thickness in the "upwind" direction. For example,
+C          C(k) = W(k)/delp(k)   if W(k) > 0;
+C          C(k) = W(k)/delp(k+1) if W(k) < 0.
+C              ( W > 0 is downward, ie, toward surface)
+C PS2: predicted PS at t+NDT (original values are over-written)
+C
+C ********************************************************************
+C NOTES:
+C This forward-in-time upstream-biased transport scheme reduces to
+C the 2nd order center-in-time center-in-space mass continuity eqn.
+C if Q = 1 (constant fields will remain constant). This also ensures
+C that the computed vertical velocity to be identical to GEOS-1 GCM
+C for on-line transport.
+C
+C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when
+C winds are noisy near poles).
+C
+C Flux-Form Semi-Lagrangian transport in the East-West direction is used
+C when and where Courant # is greater than one.
+C
+C The user needs to change the parameter Jmax or Kmax if the resolution
+C is greater than 0.5 deg in N-S or 150 layers in the vertical direction.
+C (this TransPort Core is otherwise resolution independent and can be used
+C as a library routine).
+C
+C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd
+C order accurate for non-uniform grid (vertical sigma coord.).
+C
+C Time step is limitted only by transport in the meridional direction.
+C (the FFSL scheme is not implemented in the meridional direction).
+C
+C Since only 1-D limiters are applied, negative values could
+C potentially be generated when large time step is used and when the
+C initial fields contain discontinuities.
+C This does not necessarily imply the integration is unstable.
+C These negatives are typically very small. A filling algorithm is
+C activated if the user set "fill" to be true.
+C
+C The van Leer scheme used here is nearly as accurate as the original PPM
+C due to the use of a 4th order accurate reference slope. The PPM imple-
+C mented here is an improvement over the original and is also based on
+C the 4th order reference slope.
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C     User modifiable parameters
+C
+      parameter (Jmax = 361, kmax = 150)
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C Input-Output arrays
+C
+      
+      real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP),
+     &     U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1),
+     &     BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax
+      integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE
+      integer IMRD2
+      real    PT       
+      logical  cross, fill, dum
+C
+C Local dynamic arrays
+C
+      real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP),
+     &     fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY),
+     &     WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP),
+     &     delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP),
+     &     UA(IMR,JNP),qtmp(-IMR:2*IMR)
+C
+C Local static  arrays
+C
+      real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax),
+     &     cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax)
+      data NDT0, NSTEP /0, 0/
+      data cross /.true./
+      SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML,
+     &     DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
+C
+            
+      JMR = JNP -1
+      IMJM  = IMR*JNP
+      j2 = JNP - j1 + 1
+      NSTEP = NSTEP + 1
+C
+C *********** Initialization **********************
+      if(NSTEP.eq.1) then
+c
+      write(6,*) '------------------------------------ '
+      write(6,*) 'NASA/GSFC Transport Core Version 4.5'
+      write(6,*) '------------------------------------ '
+c
+      WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1
+      WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT
+C
+C controles sur les parametres
+      if(NLAY.LT.6) then
+        write(6,*) 'NLAY must be >= 6'
+        stop
+      endif
+      if (JNP.LT.NLAY) then
+         write(6,*) 'JNP must be >= NLAY'
+        stop
+      endif
+      IMRD2=mod(IMR,2)
+      if (j1.eq.2.and.IMRD2.NE.0) then
+         write(6,*) 'if j1=2 IMR must be an even integer'
+        stop
+      endif
+
+C
+      if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then
+        write(6,*) 'Jmax or Kmax is too small'
+        stop
+      endif
+C
+      DO k=1,NLAY
+      DAP(k) = (AP(k+1) - AP(k))*PT
+      DBK(k) =  BP(k+1) - BP(k)
+      ENDDO     
+C
+      PI = 4. * ATAN(1.)
+      DL = 2.*PI / float(IMR)
+      DP =    PI / float(JMR)
+C
+      if(IGD.eq.0) then
+C Compute analytic cosine at cell edges
+            call cosa(cosp,cose,JNP,PI,DP)
+      else
+C Define cosine consistent with GEOS-GCM (using dycore2.0 or later)
+            call cosc(cosp,cose,JNP,PI,DP)
+      endif
+C
+      do 15 J=2,JMR
+15    acosp(j) = 1. / cosp(j)
+C
+C Inverse of the Scaled polar cap area.
+C
+      RCAP  = DP / (IMR*(1.-COS((j1-1.5)*DP)))
+      acosp(1)   = RCAP
+      acosp(JNP) = RCAP
+      endif
+C
+      if(NDT0 .ne. NDT) then
+      DT   = NDT
+      NDT0 = NDT
+
+	if(Umax .lt. 180.) then
+         write(6,*) 'Umax may be too small!'
+	endif
+      CR1  = abs(Umax*DT)/(DL*AE)
+      MaxDT = DP*AE / abs(Umax) + 0.5
+      write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT
+      if(MaxDT .lt. abs(NDT)) then
+            write(6,*) 'Warning!!! NDT maybe too large!'
+      endif
+C
+      if(CR1.ge.0.95) then
+      JS0 = 0
+      JN0 = 0
+      IML = IMR-2
+      ZTC = 0.
+      else
+      ZTC  = acos(CR1) * (180./PI)
+C
+      JS0 = float(JMR)*(90.-ZTC)/180. + 2
+      JS0 = max(JS0, J1+1)
+      IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
+      JN0 = JNP-JS0+1
+      endif
+C     
+C
+      do J=2,JMR
+      DTDX(j)  = DT / ( DL*AE*COSP(J) )
+
+c     print*,'dtdx=',dtdx(j)
+      DTDX5(j) = 0.5*DTDX(j)
+      enddo
+C
+      
+      DTDY  = DT /(AE*DP)
+c      print*,'dtdy=',dtdy
+      DTDY5 = 0.5*DTDY
+C
+c      write(6,*) 'J1=',J1,' J2=', J2
+      endif
+C
+C *********** End Initialization **********************
+C
+C delp = pressure thickness: the psudo-density in a hydrostatic system.
+      do  k=1,NLAY
+         do  j=1,JNP
+            do  i=1,IMR
+               delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j)
+               delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j)       
+            enddo
+         enddo
+      enddo
+          
+C
+      if(j1.ne.2) then
+      DO 40 IC=1,NC
+      DO 40 L=1,NLAY
+      DO 40 I=1,IMR
+      Q(I,  2,L,IC) = Q(I,  1,L,IC)
+40    Q(I,JMR,L,IC) = Q(I,JNP,L,IC)
+      endif
+C
+C Compute "tracer density"
+      DO 550 IC=1,NC
+      DO 44 k=1,NLAY
+      DO 44 j=1,JNP
+      DO 44 i=1,IMR
+44    DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k)
+550	continue
+C
+      do 1500 k=1,NLAY
+C
+      if(IGD.eq.0) then
+C Convert winds on A-Grid to Courant # on C-Grid.
+      call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      else
+C Convert winds on C-grid to Courant #
+      do 45 j=j1,j2
+      do 45 i=2,IMR
+45    CRX(i,J) = dtdx(j)*U(i-1,j,k)
+   
+C
+      do 50 j=j1,j2
+50    CRX(1,J) = dtdx(j)*U(IMR,j,k)
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY*V(i,1,k)
+      endif
+C     
+C Determine JS and JN
+      JS = j1
+      JN = j2
+C
+      do j=JS0,j1+1,-1
+      do i=1,IMR
+      if(abs(CRX(i,j)).GT.1.) then
+            JS = j
+            go to 2222
+      endif
+      enddo
+      enddo
+C
+2222  continue
+      do j=JN0,j2-1
+      do i=1,IMR
+      if(abs(CRX(i,j)).GT.1.) then
+            JN = j
+            go to 2233
+      endif
+      enddo
+      enddo
+2233  continue
+C
+      if(j1.ne.2) then           ! Enlarged polar cap.
+      do i=1,IMR
+      DPI(i,  2,k) = 0.
+      DPI(i,JMR,k) = 0.
+      enddo
+      endif
+C
+C ******* Compute horizontal mass fluxes ************
+C
+C N-S component
+      do j=j1,j2+1
+      D5 = 0.5 * COSE(j)
+      do i=1,IMR
+      ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k))
+      enddo
+      enddo
+C
+      do 95 j=j1,j2
+      DO 95 i=1,IMR
+95    DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j)
+C
+C Poles
+      sum1 = ymass(IMR,j1  )
+      sum2 = ymass(IMR,J2+1)
+      do i=1,IMR-1
+      sum1 = sum1 + ymass(i,j1  )
+      sum2 = sum2 + ymass(i,J2+1)
+      enddo
+C
+      sum1 = - sum1 * RCAP
+      sum2 =   sum2 * RCAP
+      do i=1,IMR
+      DPI(i,  1,k) = sum1
+      DPI(i,JNP,k) = sum2
+      enddo
+C
+C E-W component
+C
+      do j=j1,j2
+      do i=2,IMR
+      PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k))
+      enddo
+      enddo
+C
+      do j=j1,j2
+      PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k))
+      enddo
+C
+      do 110 j=j1,j2
+      DO 110 i=1,IMR
+110   xmass(i,j) = PU(i,j)*CRX(i,j)
+C
+      DO 120 j=j1,j2
+      DO 120 i=1,IMR-1
+120   DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j)
+C
+      DO 130 j=j1,j2
+130   DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j)
+C
+      DO j=j1,j2
+      do i=1,IMR-1
+      UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j))
+      enddo
+      enddo
+C
+      DO j=j1,j2
+      UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j))
+      enddo
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Rajouts pour LMDZ.3.3
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      do i=1,IMR
+         do j=1,JNP
+             VA(i,j)=0.
+         enddo
+      enddo
+
+      do i=1,imr*(JMR-1)
+      VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3))
+      enddo
+C
+      if(j1.eq.2) then
+	IMH = IMR/2
+      do i=1,IMH
+      VA(i,      1) = 0.5*(CRY(i,2)-CRY(i+IMH,2))
+      VA(i+IMH,  1) = -VA(i,1)
+      VA(i,    JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR))
+      VA(i+IMH,JNP) = -VA(i,JNP)
+      enddo
+      VA(IMR,1)=VA(1,1)
+      VA(IMR,JNP)=VA(1,JNP)
+      endif
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+      do 1000 IC=1,NC
+C
+      do i=1,IMJM
+      wk1(i,1,1) = 0.
+      wk1(i,1,2) = 0.
+      enddo
+C
+C E-W advective cross term
+      do 250 j=J1,J2
+      if(J.GT.JS  .and. J.LT.JN) GO TO 250
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j,k,IC)
+      enddo
+C
+      do i=-IML,0
+      qtmp(i)       = q(IMR+i,j,k,IC)
+      qtmp(IMR+1-i) = q(1-i,j,k,IC)
+      enddo
+C
+      DO 230 i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.0.) then
+      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+      else
+      wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+      endif
+      wk1(i,j,1) = wk1(i,j,1) - qtmp(i)
+230   continue
+250   continue
+C
+      if(JN.ne.0) then
+      do j=JS+1,JN-1
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j,k,IC)
+      enddo
+C
+      qtmp(0)     = q(IMR,J,k,IC)
+      qtmp(IMR+1) = q(  1,J,k,IC)
+C
+      do i=1,imr
+      iu = i - UA(i,j)
+      wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1))
+      enddo
+      enddo
+      endif
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Contribution from the N-S advection
+      do i=1,imr*(j2-j1+1)
+      JT = float(J1) - VA(i,j1)
+      wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC))
+      enddo
+C
+      do i=1,IMJM
+      wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1)
+      wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2)
+      enddo
+C
+	if(cross) then
+C Add cross terms in the vertical direction.
+	if(IORD .GE. 2) then
+		iad = 2
+	else
+		iad = 1
+	endif
+C
+	if(JORD .GE. 2) then
+		jad = 2
+	else
+		jad = 1
+	endif
+      call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad)
+      call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad)
+      do j=1,JNP
+      do i=1,IMR
+      q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j)
+      enddo
+      enddo
+      endif
+C
+      call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2)
+     &        ,CRX,fx1,xmass,IORD)
+
+      call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY,
+     &  DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD)
+C
+1000  continue
+1500  continue
+C
+C ******* Compute vertical mass flux (same unit as PS) ***********
+C
+C 1st step: compute total column mass CONVERGENCE.
+C
+      do 320 j=1,JNP
+      do 320 i=1,IMR
+320   CRY(i,j) = DPI(i,j,1)
+C
+      do 330 k=2,NLAY
+      do 330 j=1,JNP
+      do 330 i=1,IMR
+      CRY(i,j)  = CRY(i,j) + DPI(i,j,k)
+330   continue
+C
+      do 360 j=1,JNP
+      do 360 i=1,IMR
+C
+C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption.
+C Changes (increases) to surface pressure = total column mass convergence
+C
+      PS2(i,j)  = PS1(i,j) + CRY(i,j)
+C
+C 3rd step: compute vertical mass flux from mass conservation principle.
+C
+      W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j)
+      W(i,j,NLAY) = 0.
+360   continue
+C
+      do 370 k=2,NLAY-1
+      do 370 j=1,JNP
+      do 370 i=1,IMR
+      W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j)
+370   continue
+C
+      DO 380 k=1,NLAY
+      DO 380 j=1,JNP
+      DO 380 i=1,IMR
+      delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j)
+380   continue
+C
+	KRD = max(3, KORD)
+      do 4000 IC=1,NC
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+   
+      call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI,
+     &           DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD)
+C
+    
+      if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2,
+     &                     cosp,acosp,.false.,IC,NSTEP)
+C
+C Recover tracer mixing ratio from "density" using predicted
+C "air density" (pressure thickness) at time-level n+1
+C
+      DO k=1,NLAY
+      DO j=1,JNP
+      DO i=1,IMR
+            Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k)
+c            print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC)
+      enddo
+      enddo
+      enddo
+C     
+      if(j1.ne.2) then
+      DO 400 k=1,NLAY
+      DO 400 I=1,IMR
+c     j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord
+      Q(I,  2,k,IC) = Q(I,  1,k,IC)
+      Q(I,JMR,k,IC) = Q(I,JNP,k,IC)
+400   CONTINUE
+      endif
+4000  continue
+C
+      if(j1.ne.2) then
+      DO 5000 k=1,NLAY
+      DO 5000 i=1,IMR
+      W(i,  2,k) = W(i,  1,k)
+      W(i,JMR,k) = W(i,JNP,k)
+5000  continue
+      endif
+C
+      RETURN
+      END
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+      subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6,
+     &                 flux,wk1,wk2,wz2,delp,KORD)
+      parameter ( kmax = 150 )
+      parameter ( R23 = 2./3., R3 = 1./3.)
+      real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY),
+     &     wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY),
+     &     DQDT(IMR,JNP,NLAY)
+C Assuming JNP >= NLAY
+      real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*),
+     &     wz2(IMR,*)
+C
+      JMR = JNP - 1
+      IMJM = IMR*JNP
+      NLAYM1 = NLAY - 1
+C
+      LMT = KORD - 3
+C
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Compute DC for PPM
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      do 1000 k=1,NLAYM1
+      do 1000 i=1,IMJM
+      DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k)
+1000  continue
+C
+      DO 1220 k=2,NLAYM1
+      DO 1220 I=1,IMJM    
+       c0 =  delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1))
+       c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k))    
+       c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k))
+      tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1))
+      Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k)
+      Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1))
+      DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp)   
+1220  CONTINUE
+     
+C     
+C ****6***0*********0*********0*********0*********0*********0**********72
+C Loop over latitudes  (to save memory)
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 2000 j=1,JNP
+      if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000
+C
+      DO k=1,NLAY
+      DO i=1,IMR
+      wz2(i,k) =   WZ(i,j,k)
+      wk1(i,k) =    P(i,j,k)
+      wk2(i,k) = delp(i,j,k)
+      flux(i,k) = DC(i,j,k)  !this flux is actually the monotone slope
+      enddo
+      enddo
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C Compute first guesses at cell interfaces
+C First guesses are required to be continuous.
+C ****6***0*********0*********0*********0*********0*********0**********72
+C
+C three-cell parabolic subgrid distribution at model top
+C two-cell parabolic with zero gradient subgrid distribution 
+C at the surface.
+C
+C First guess top edge value
+      DO 10 i=1,IMR
+C three-cell PPM
+C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
+      a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/
+     &         (wk2(i,1)+wk2(i,2)) ) /
+     &       ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) )
+      b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - 
+     &    R23*a*(2.*wk2(i,1)+wk2(i,2))
+      AL(i,1) =  wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b)
+      AL(i,2) =  wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1)
+C
+C Check if change sign
+      if(wk1(i,1)*AL(i,1).le.0.) then
+		 AL(i,1) = 0.
+             flux(i,1) = 0.
+	else
+             flux(i,1) =  wk1(i,1) - AL(i,1)
+	endif
+10    continue
+C
+C Bottom
+      DO 15 i=1,IMR
+C 2-cell PPM with zero gradient right at the surface
+C
+      fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 /
+     & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1)))
+      AR(i,NLAY) = wk1(i,NLAY) + fct
+      AL(i,NLAY) = wk1(i,NLAY) - (fct+fct)
+      if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0.
+      flux(i,NLAY) = AR(i,NLAY) -  wk1(i,NLAY)
+15    continue
+     
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C 4th order interpolation in the interior.
+C****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 14 k=3,NLAYM1
+      DO 12 i=1,IMR
+      c1 =  DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k))
+      c2 =  2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1))
+      A1   =  (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k))
+      A2   =  (wk2(i,k  )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1))
+      AL(i,k) = wk1(i,k-1) + c1 + c2 *
+     &        ( wk2(i,k  )*(c1*(A1 - A2)+A2*flux(i,k-1)) -
+     &          wk2(i,k-1)*A1*flux(i,k)  )
+C      print *,'AL1',i,k, AL(i,k)
+12    CONTINUE
+14    continue
+C
+      do 20 i=1,IMR*NLAYM1
+      AR(i,1) = AL(i,2)
+C      print *,'AR1',i,AR(i,1)
+20    continue
+C
+      do 30 i=1,IMR*NLAY
+      A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1)))
+C      print *,'A61',i,A6(i,1)
+30    continue
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C Top & Bot always monotonic
+      call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0)
+      call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY),
+     &            wk1(1,NLAY),IMR,0)
+C
+C Interior depending on KORD
+      if(LMT.LE.2)
+     &  call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2),
+     &              IMR*(NLAY-2),LMT)
+C
+C****6***0*********0*********0*********0*********0*********0**********72
+C
+      DO 140 i=1,IMR*NLAYM1
+      IF(wz2(i,1).GT.0.) then
+        CM = wz2(i,1) / wk2(i,1)
+        flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM))
+      else
+C        print *,'test2-0',i,j,wz2(i,1),wk2(i,2)
+        CP= wz2(i,1) / wk2(i,2)        
+C        print *,'testCP',CP
+        flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP))
+C        print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23
+      endif
+140   continue
+C
+      DO 250 i=1,IMR*NLAYM1
+      flux(i,2) = wz2(i,1) * flux(i,2)
+250   continue
+C
+      do 350 i=1,IMR
+      DQ(i,j,   1) = DQ(i,j,   1) - flux(i,   2)
+      DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY)
+350   continue
+C
+      do 360 k=2,NLAYM1
+      do 360 i=1,IMR
+360   DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1)
+2000  continue
+      return
+      end
+C
+      subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC,
+     &               fx1,xmass,IORD)
+      dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP)
+     &    ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML)
+      dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR)
+C
+      IMP = IMR + 1
+C
+C van Leer at high latitudes
+      jvan = max(1,JNP/18)
+      j1vl = j1+jvan
+      j2vl = j2-jvan
+C
+      do 1310 j=j1,j2
+C
+      do i=1,IMR
+      qtmp(i) = q(i,j)
+      enddo
+C
+      if(j.ge.JN .or. j.le.JS) goto 2222
+C ************* Eulerian **********
+C
+      qtmp(0)     = q(IMR,J)
+      qtmp(-1)    = q(IMR-1,J)
+      qtmp(IMP)   = q(1,J)
+      qtmp(IMP+1) = q(2,J)
+C
+      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1406 i=1,IMR
+      iu = float(i) - uc(i,j)
+1406  fx1(i) = qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+      DC(0) = DC(IMR)
+C
+      if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then
+      DO 1408 i=1,IMR
+      iu = float(i) - uc(i,j)
+1408  fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j))
+      else
+      call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
+      endif
+C
+      ENDIF
+C
+      DO 1506 i=1,IMR
+1506  fx1(i) = fx1(i)*xmass(i,j)
+C
+      goto 1309
+C
+C ***** Conservative (flux-form) Semi-Lagrangian transport *****
+C
+2222  continue
+C
+      do i=-IML,0
+      qtmp(i)     = q(IMR+i,j)
+      qtmp(IMP-i) = q(1-i,j)
+      enddo
+C
+      IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN
+      DO 1306 i=1,IMR
+      itmp = INT(uc(i,j))
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1306  fx1(i) = (uc(i,j) - itmp)*qtmp(iu)
+      ELSE
+      call xmist(IMR,IML,Qtmp,DC)
+C
+      do i=-IML,0
+      DC(i)     = DC(IMR+i)
+      DC(IMP-i) = DC(1-i)
+      enddo
+C
+      DO 1307 i=1,IMR
+      itmp = INT(uc(i,j))
+      rut  = uc(i,j) - itmp
+      ISAVE(i) = i - itmp
+      iu = i - uc(i,j)
+1307  fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut))
+      ENDIF
+C
+      do 1308 i=1,IMR
+      IF(uc(i,j).GT.1.) then
+CDIR$ NOVECTOR
+        do ist = ISAVE(i),i-1
+        fx1(i) = fx1(i) + qtmp(ist)
+        enddo
+      elseIF(uc(i,j).LT.-1.) then
+        do ist = i,ISAVE(i)-1
+        fx1(i) = fx1(i) - qtmp(ist)
+        enddo
+CDIR$ VECTOR
+      endif
+1308  continue
+      do i=1,IMR
+      fx1(i) = PU(i,j)*fx1(i)
+      enddo
+C
+C ***************************************
+C
+1309  fx1(IMP) = fx1(1)
+      DO 1215 i=1,IMR
+1215  DQ(i,j) =  DQ(i,j) + fx1(i)-fx1(i+1)
+C
+C ***************************************
+C
+1310  continue
+      return
+      end
+C
+      subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
+      DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR)
+      integer LMT 
+c      logical first
+c      data first /.true./
+c      SAVE LMT
+c      if(first) then
+C
+C correction calcul de LMT a chaque passage pour pouvoir choisir
+c plusieurs schemas PPM pour differents traceurs
+c      IF (IORD.LE.0) then
+c            if(IMR.GE.144) then
+c                  LMT = 0
+c            elseif(IMR.GE.72) then
+c                  LMT = 1
+c            else
+c                  LMT = 2
+c            endif
+c      else
+c            LMT = IORD - 3
+c      endif
+C
+      LMT = IORD - 3
+c      write(6,*) 'PPM option in E-W direction = ', LMT
+c      first = .false.
+C      endif
+C
+      DO 10 i=1,IMR
+10    AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3
+C
+      do 20 i=1,IMR-1
+20    AR(i) = AL(i+1)
+      AR(IMR) = AL(1)
+C
+      do 30 i=1,IMR
+30    A6(i) = 3.*(p(i)+p(i)  - (AL(i)+AR(i)))
+C
+      if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT)
+C
+      AL(0) = AL(IMR)
+      AR(0) = AR(IMR)
+      A6(0) = A6(IMR)
+C
+      DO i=1,IMR
+      IF(UT(i).GT.0.) then
+      flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) +
+     &                 A6(i-1)*(1.-R23*UT(i)) )
+      else
+      flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) +
+     &                        A6(i)*(1.+R23*UT(i)))
+      endif
+      enddo
+      return
+      end
+C
+      subroutine xmist(IMR,IML,P,DC)
+      parameter( R24 = 1./24.)
+      dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+C
+      do 10  i=1,IMR
+      tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2))
+      Pmax = max(P(i-1), p(i), p(i+1)) - p(i)
+      Pmin = p(i) - min(P(i-1), p(i), p(i+1))
+10    DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp)
+      return
+      end
+C
+      subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2
+     &              ,ymass,fx,A6,AR,AL,JORD)
+      dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP)
+     &       ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP)
+C Work array
+      DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+C
+      JMR = JNP - 1
+      len = IMR*(J2-J1+2)
+C
+      if(JORD.eq.1) then
+      DO 1000 i=1,len
+      JT = float(J1) - VC(i,J1)
+1000  fx(i,j1) = p(i,JT)
+      else
+   
+      call ymist(IMR,JNP,j1,P,DC2,4)
+C
+      if(JORD.LE.0 .or. JORD.GE.3) then
+   
+      call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+    
+      else
+      DO 1200 i=1,len
+      JT = float(J1) - VC(i,J1)
+1200  fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
+      endif
+      endif
+C
+      DO 1300 i=1,len
+1300  fx(i,j1) = fx(i,j1)*ymass(i,j1)
+C
+      DO 1400 j=j1,j2
+      DO 1400 i=1,IMR
+1400  DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j)
+C
+C Poles
+      sum1 = fx(IMR,j1  )
+      sum2 = fx(IMR,J2+1)
+      do i=1,IMR-1
+      sum1 = sum1 + fx(i,j1  )
+      sum2 = sum2 + fx(i,J2+1)
+      enddo
+C
+      sum1 = DQ(1,  1) - sum1 * RCAP
+      sum2 = DQ(1,JNP) + sum2 * RCAP
+      do i=1,IMR
+      DQ(i,  1) = sum1
+      DQ(i,JNP) = sum2
+      enddo
+C
+      if(j1.ne.2) then
+      do i=1,IMR
+      DQ(i,  2) = sum1
+      DQ(i,JMR) = sum2
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine  ymist(IMR,JNP,j1,P,DC,ID)
+      parameter ( R24 = 1./24. )
+      dimension P(IMR,JNP),DC(IMR,JNP)
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      IJM3 = IMR*(JMR-3)
+C
+      IF(ID.EQ.2) THEN
+      do 10 i=1,IMR*(JMR-1)
+      tmp = 0.25*(p(i,3) - p(i,1))
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+10    CONTINUE
+      ELSE
+      do 12 i=1,IMH
+C J=2
+      tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+C J=JMR
+      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24
+      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+12    CONTINUE
+      do 14 i=IMH+1,IMR
+C J=2
+      tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24
+      Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2)
+      Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3))
+      DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+C J=JMR
+      tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24
+      Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR)
+      Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP))
+      DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+14    CONTINUE
+C
+      do 15 i=1,IJM3
+      tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24
+      Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3)
+      Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4))
+      DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp)
+15    CONTINUE
+      ENDIF
+C
+      if(j1.ne.2) then
+      do i=1,IMR
+      DC(i,1) = 0.
+      DC(i,JNP) = 0.
+      enddo
+      else
+C Determine slopes in polar caps for scalars!
+C
+      do 13 i=1,IMH
+C South
+      tmp = 0.25*(p(i,2) - p(i+imh,2))
+      Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1)
+      Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2))
+      DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp)
+C North.
+      tmp = 0.25*(p(i+imh,JMR) - p(i,JMR))
+      Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP)
+      Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR))
+      DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp)
+13    continue
+C
+      do 25 i=imh+1,IMR
+      DC(i,  1) =  - DC(i-imh,  1)
+      DC(i,JNP) =  - DC(i-imh,JNP)
+25    continue
+      endif
+      return
+      end
+C
+      subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
+      parameter ( R3 = 1./3., R23 = 2./3. )
+      real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
+C Local work arrays.
+      real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+      integer LMT
+c      logical first
+C      data first /.true./
+C      SAVE LMT
+C
+      IMH = IMR / 2
+      JMR = JNP - 1
+      j11 = j1-1
+      IMJM1 = IMR*(J2-J1+2)
+      len   = IMR*(J2-J1+3)
+C      if(first) then
+C      IF(JORD.LE.0) then
+C            if(JMR.GE.90) then
+C                  LMT = 0
+C            elseif(JMR.GE.45) then
+C                  LMT = 1
+C            else
+C                  LMT = 2
+C            endif
+C      else
+C            LMT = JORD - 3
+C      endif
+C
+C      first = .false.
+C      endif
+C     
+c modifs pour pouvoir choisir plusieurs schemas PPM
+      LMT = JORD - 3      
+C
+      DO 10 i=1,IMR*JMR        
+      AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3
+      AR(i,1) = AL(i,2)
+10    CONTINUE
+C
+CPoles:
+C
+      DO i=1,IMH
+      AL(i,1) = AL(i+IMH,2)
+      AL(i+IMH,1) = AL(i,2)
+C
+      AR(i,JNP) = AR(i+IMH,JMR)
+      AR(i+IMH,JNP) = AR(i,JMR)
+      ENDDO
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   Rajout pour LMDZ.3.3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      AR(IMR,1)=AL(1,1)
+      AR(IMR,JNP)=AL(1,JNP)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      
+           
+      do 30 i=1,len
+30    A6(i,j11) = 3.*(p(i,j11)+p(i,j11)  - (AL(i,j11)+AR(i,j11)))
+C
+      if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11)
+     &                       ,AL(1,j11),P(1,j11),len,LMT)
+C
+     
+      DO 140 i=1,IMJM1
+      IF(VC(i,j1).GT.0.) then
+      flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) +
+     &                         A6(i,j11)*(1.-R23*VC(i,j1)) )
+      else
+      flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) +
+     &                        A6(i,j1)*(1.+R23*VC(i,j1)))
+      endif
+140   continue
+      return
+      end
+C
+	subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
+	REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
+        REAL WK(IMR,-1:JNP+2)
+C
+	JMR = JNP-1
+	IMH = IMR/2
+	do j=1,JNP
+	do i=1,IMR
+	wk(i,j) = p(i,j)
+	enddo
+	enddo
+C Poles:
+	do i=1,IMH
+	wk(i,   -1) = p(i+IMH,3)
+	wk(i+IMH,-1) = p(i,3)
+	wk(i,    0) = p(i+IMH,2)
+	wk(i+IMH,0) = p(i,2)
+	wk(i,JNP+1) = p(i+IMH,JMR)
+	wk(i+IMH,JNP+1) = p(i,JMR)
+	wk(i,JNP+2) = p(i+IMH,JNP-2)
+	wk(i+IMH,JNP+2) = p(i,JNP-2)
+	enddo
+c        write(*,*) 'toto 1' 
+C --------------------------------
+      IF(IAD.eq.2) then
+      do j=j1-1,j2+1
+      do i=1,IMR
+c      write(*,*) 'avt NINT','i=',i,'j=',j
+      JP = NINT(VA(i,j))      
+      rv = JP - VA(i,j)
+c      write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv
+      JP = j - JP
+c      write(*,*) 'JP2=',JP
+      a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp)
+      b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1))
+c      write(*,*) 'a1=',a1,'b1=',b1
+      ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j)
+      enddo
+      enddo
+c      write(*,*) 'toto 2'
+C
+      ELSEIF(IAD.eq.1) then
+	do j=j1-1,j2+1
+      do i=1,imr
+      JP = float(j)-VA(i,j)
+      ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1))
+      enddo
+      enddo
+      ENDIF
+C
+	if(j1.ne.2) then
+	sum1 = 0.
+	sum2 = 0.
+      do i=1,imr
+      sum1 = sum1 + ady(i,2)
+      sum2 = sum2 + ady(i,JMR)
+      enddo
+	sum1 = sum1 / IMR
+	sum2 = sum2 / IMR
+C
+      do i=1,imr
+      ady(i,  2) =  sum1
+      ady(i,JMR) =  sum2
+      ady(i,  1) =  sum1
+      ady(i,JNP) =  sum2
+      enddo
+	else
+C Poles:
+	sum1 = 0.
+	sum2 = 0.
+      do i=1,imr
+      sum1 = sum1 + ady(i,1)
+      sum2 = sum2 + ady(i,JNP)
+      enddo
+	sum1 = sum1 / IMR
+	sum2 = sum2 / IMR
+C
+      do i=1,imr
+      ady(i,  1) =  sum1
+      ady(i,JNP) =  sum2
+      enddo
+	endif
+C
+	return
+	end
+C
+	subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD)
+	REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
+C
+	JMR = JNP-1
+      do 1309 j=j1,j2
+      if(J.GT.JS  .and. J.LT.JN) GO TO 1309
+C
+      do i=1,IMR
+      qtmp(i) = p(i,j)
+      enddo
+C
+      do i=-IML,0
+      qtmp(i)       = p(IMR+i,j)
+      qtmp(IMR+1-i) = p(1-i,j)
+      enddo
+C
+      IF(IAD.eq.2) THEN
+      DO i=1,IMR
+      IP = NINT(UA(i,j))
+      ru = IP - UA(i,j)
+      IP = i - IP
+      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+      adx(i,j) = qtmp(ip) + ru*(a1*ru + b1)
+      enddo
+      ELSEIF(IAD.eq.1) then
+      DO i=1,IMR
+      iu = UA(i,j)
+      ru = UA(i,j) - iu
+      iiu = i-iu
+      if(UA(i,j).GE.0.) then
+      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu))
+      else
+      adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
+      endif
+      enddo
+      ENDIF
+C
+      do i=1,IMR
+      adx(i,j) = adx(i,j) - p(i,j)
+      enddo
+1309  continue
+C
+C Eulerian upwind
+C
+      do j=JS+1,JN-1
+C
+      do i=1,IMR
+      qtmp(i) = p(i,j)
+      enddo
+C
+      qtmp(0)     = p(IMR,J)
+      qtmp(IMR+1) = p(1,J)
+C
+      IF(IAD.eq.2) THEN
+      qtmp(-1)     = p(IMR-1,J)
+      qtmp(IMR+2) = p(2,J)
+      do i=1,imr
+      IP = NINT(UA(i,j))
+      ru = IP - UA(i,j)
+      IP = i - IP
+      a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip)
+      b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1))
+      adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1)
+      enddo
+      ELSEIF(IAD.eq.1) then
+C 1st order
+      DO i=1,IMR
+      IP = i - UA(i,j)
+      adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1))
+      enddo
+      ENDIF
+      enddo
+C
+	if(j1.ne.2) then
+      do i=1,IMR
+      adx(i,  2) = 0.
+      adx(i,JMR) = 0.
+      enddo
+	endif
+C set cross term due to x-adv at the poles to zero.
+      do i=1,IMR
+      adx(i,  1) = 0.
+      adx(i,JNP) = 0.
+      enddo
+	return
+	end
+C
+      subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT)
+C
+C A6 =  CURVATURE OF THE TEST PARABOLA
+C AR =  RIGHT EDGE VALUE OF THE TEST PARABOLA
+C AL =  LEFT  EDGE VALUE OF THE TEST PARABOLA
+C DC =  0.5 * MISMATCH
+C P  =  CELL-AVERAGED VALUE
+C IM =  VECTOR LENGTH
+C
+C OPTIONS:
+C
+C LMT = 0: FULL MONOTONICITY
+C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS)
+C LMT = 2: POSITIVE-DEFINITE CONSTRAINT
+C
+      parameter ( R12 = 1./12. )
+      dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+C
+      if(LMT.eq.0) then
+C Full constraint
+      do 100 i=1,IM
+      if(DC(i).eq.0.) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      else
+      da1  = AR(i) - AL(i)
+      da2  = da1**2
+      A6DA = A6(i)*da1
+      if(A6DA .lt. -da2) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      elseif(A6DA .gt. da2) then
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+      endif
+100   continue
+      elseif(LMT.eq.1) then
+C Semi-monotonic constraint
+      do 150 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. AL(i)) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      else
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+150   continue
+      elseif(LMT.eq.2) then
+      do 250 i=1,IM
+      if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250
+      fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
+      if(fmin.ge.0.) go to 250
+      if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then
+            AR(i) = p(i)
+            AL(i) = p(i)
+            A6(i) = 0.
+      elseif(AR(i) .gt. AL(i)) then
+            A6(i) = 3.*(AL(i)-p(i))
+            AR(i) = AL(i) - A6(i)
+      else
+            A6(i) = 3.*(AR(i)-p(i))
+            AL(i) = AR(i) - A6(i)
+      endif
+250   continue
+      endif
+      return
+      end
+C
+      subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
+      dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*)
+C
+      do 35 j=j1,j2
+      do 35 i=2,IMR
+35    CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j))
+C
+      do 45 j=j1,j2
+45    CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j))
+C
+      do 55 i=1,IMR*JMR
+55    CRY(i,2) = DTDY5*(V(i,2)+V(i,1))
+      return
+      end
+C
+      subroutine cosa(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+      JMR = JNP-1
+      do 55 j=2,JNP
+        ph5  =  -0.5*PI + (FLOAT(J-1)-0.5)*DP
+55      cose(j) = cos(ph5)
+C
+      JEQ = (JNP+1) / 2
+      if(JMR .eq. 2*(JMR/2) ) then
+      do j=JNP, JEQ+1, -1
+       cose(j) =  cose(JNP+2-j)
+      enddo
+      else
+C cell edge at equator.
+       cose(JEQ+1) =  1.
+      do j=JNP, JEQ+2, -1
+       cose(j) =  cose(JNP+2-j)
+       enddo
+      endif
+C
+      do 66 j=2,JMR
+66    cosp(j) = 0.5*(cose(j)+cose(j+1))
+      cosp(1) = 0.
+      cosp(JNP) = 0.
+      return
+      end
+C
+      subroutine cosc(cosp,cose,JNP,PI,DP)
+      dimension cosp(*),cose(*)
+C
+      phi = -0.5*PI
+      do 55 j=2,JNP-1
+      phi  =  phi + DP
+55    cosp(j) = cos(phi)
+        cosp(  1) = 0.
+        cosp(JNP) = 0.
+C
+      do 66 j=2,JNP
+        cose(j) = 0.5*(cosp(j)+cosp(j-1))
+66    CONTINUE
+C
+      do 77 j=2,JNP-1
+       cosp(j) = 0.5*(cose(j)+cose(j+1))
+77    CONTINUE
+      return
+      end
+C
+      SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp,
+     &                   cross,IC,NSTEP)
+C
+      parameter( tiny = 1.E-60 )
+      DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
+      logical cross
+C
+      NLAYM1 = NLAY-1
+      len = IMR*(j2-j1+1)
+      ip = 0
+C
+C Top layer
+      L = 1
+	icr = 1
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 50
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 50
+C
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 50
+C
+C Vertical filling...
+      do i=1,len
+      IF( Q(i,j1,1).LT.0.) THEN
+      ip = ip + 1
+          Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1)
+          Q(i,j1,1) = 0.
+      endif
+      enddo
+C
+50    continue
+      DO 225 L = 2,NLAYM1
+      icr = 1
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 225
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) go to 225
+      if(cross) then
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      endif
+      if(icr.eq.0) goto 225
+C
+      do i=1,len
+      IF( Q(I,j1,L).LT.0.) THEN
+C
+      ip = ip + 1
+C From above
+          qup =  Q(I,j1,L-1)
+          qly = -Q(I,j1,L)
+          dup  = min(qly,qup)
+          Q(I,j1,L-1) = qup - dup
+          Q(I,j1,L  ) = dup-qly
+C Below
+          Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L)
+          Q(I,j1,L)   = 0.
+      ENDIF
+      ENDDO
+225   CONTINUE
+C
+C BOTTOM LAYER
+      sum = 0.
+      L = NLAY
+C
+      call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      if(ipy.eq.0) goto 911
+      call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      if(ipx.eq.0) goto 911
+C
+      call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      if(icr.eq.0) goto 911
+C
+      DO  I=1,len
+      IF( Q(I,j1,L).LT.0.) THEN
+      ip = ip + 1
+c
+C From above
+C
+          qup = Q(I,j1,NLAYM1)
+          qly = -Q(I,j1,L)
+          dup = min(qly,qup)
+          Q(I,j1,NLAYM1) = qup - dup
+C From "below" the surface.
+          sum = sum + qly-dup
+          Q(I,j1,L) = 0.
+       ENDIF
+      ENDDO
+C
+911   continue
+C
+      if(ip.gt.IMR) then
+      write(6,*) 'IC=',IC,' STEP=',NSTEP,
+     &           ' Vertical filling pts=',ip
+      endif
+C
+      if(sum.gt.1.e-25) then
+      write(6,*) IC,NSTEP,' Mass source from the ground=',sum
+      endif
+      RETURN
+      END
+C
+      subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+      icr = 0
+      do 65 j=j1+1,j2-1
+      DO 50 i=1,IMR-1
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-E
+      dn = q(i+1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i+1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-E
+      ds = q(i+1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i+1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+50    continue
+      if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65
+      DO 55 i=2,IMR
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-W
+      dn = q(i-1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i-1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-W
+      ds = q(i-1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i-1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+55    continue
+C *****************************************
+C i=1
+      i=1
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-W
+      dn = q(IMR,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(IMR,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-W
+      ds = q(IMR,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(IMR,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+C *****************************************
+C i=IMR
+      i=IMR
+      IF(q(i,j).LT.0.) THEN
+      icr =  1
+      dq  = - q(i,j)*cosp(j)
+C N-E
+      dn = q(1,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(1,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C S-E
+      ds = q(1,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(1,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+C *****************************************
+65    continue
+C
+      do i=1,IMR
+      if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then
+      icr = 1
+      goto 80
+      endif
+      enddo
+C
+80    continue
+C
+      if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then
+      icr = 1
+      endif
+C
+      return
+      end
+C
+      subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
+      dimension q(IMR,*),cosp(*),acosp(*)
+c      logical first
+c      data first /.true./
+c      save cap1
+C
+c      if(first) then
+      DP = 4.*ATAN(1.)/float(JNP-1)
+      CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
+c      first = .false.
+c      endif
+C
+      ipy = 0
+      do 55 j=j1+1,j2-1
+      DO 55 i=1,IMR
+      IF(q(i,j).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j)*cosp(j)
+C North
+      dn = q(i,j+1)*cosp(j+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i,j+1) = (dn - d1)*acosp(j+1)
+      dq = dq - d1
+C South
+      ds = q(i,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+55    continue
+C
+      do i=1,imr
+      IF(q(i,j1).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j1)*cosp(j1)
+C North
+      dn = q(i,j1+1)*cosp(j1+1)
+      d0 = max(0.,dn)
+      d1 = min(dq,d0)
+      q(i,j1+1) = (dn - d1)*acosp(j1+1)
+      q(i,j1) = (d1 - dq)*acosp(j1) + tiny
+      endif
+      enddo
+C
+      j = j2
+      do i=1,imr
+      IF(q(i,j).LT.0.) THEN
+      ipy =  1
+      dq  = - q(i,j)*cosp(j)
+C South
+      ds = q(i,j-1)*cosp(j-1)
+      d0 = max(0.,ds)
+      d2 = min(dq,d0)
+      q(i,j-1) = (ds - d2)*acosp(j-1)
+      q(i,j) = (d2 - dq)*acosp(j) + tiny
+      endif
+      enddo
+C
+C Check Poles.
+      if(q(1,1).lt.0.) then
+      dq = q(1,1)*cap1/float(IMR)*acosp(j1)
+      do i=1,imr
+      q(i,1) = 0.
+      q(i,j1) = q(i,j1) + dq
+      if(q(i,j1).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      if(q(1,JNP).lt.0.) then
+      dq = q(1,JNP)*cap1/float(IMR)*acosp(j2)
+      do i=1,imr
+      q(i,JNP) = 0.
+      q(i,j2) = q(i,j2) + dq
+      if(q(i,j2).lt.0.) ipy = 1
+      enddo
+      endif
+C
+      return
+      end
+C
+      subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
+      dimension q(IMR,*),qtmp(JNP,IMR)
+C
+      ipx = 0
+C Copy & swap direction for vectorization.
+      do 25 i=1,imr
+      do 25 j=j1,j2
+25    qtmp(j,i) = q(i,j)
+C
+      do 55 i=2,imr-1
+      do 55 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,i-1))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,i-1) = qtmp(j,i-1) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,i+1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,i+1) = qtmp(j,i+1) - d2
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+55    continue
+c
+      i=1
+      do 65 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,imr))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,imr) = qtmp(j,imr) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,i+1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,i+1) = qtmp(j,i+1) - d2
+c
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+65    continue
+      i=IMR
+      do 75 j=j1,j2
+      if(qtmp(j,i).lt.0.) then
+      ipx =  1
+c west
+      d0 = max(0.,qtmp(j,i-1))
+      d1 = min(-qtmp(j,i),d0)
+      qtmp(j,i-1) = qtmp(j,i-1) - d1
+      qtmp(j,i) = qtmp(j,i) + d1
+c east
+      d0 = max(0.,qtmp(j,1))
+      d2 = min(-qtmp(j,i),d0)
+      qtmp(j,1) = qtmp(j,1) - d2
+c
+      qtmp(j,i) = qtmp(j,i) + d2 + tiny
+      endif
+75    continue
+C
+      if(ipx.ne.0) then
+      do 85 j=j1,j2
+      do 85 i=1,imr
+85    q(i,j) = qtmp(j,i)
+      else
+C
+C Poles.
+      if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1
+      endif
+      return
+      end
+C
+      subroutine zflip(q,im,km,nc)
+C This routine flip the array q (in the vertical).
+      real q(im,km,nc)
+C local dynamic array
+      real qtmp(im,km)
+C
+      do 4000 IC = 1, nc
+C
+      do 1000 k=1,km
+      do 1000 i=1,im
+      qtmp(i,k) = q(i,km+1-k,IC)
+1000  continue
+C
+      do 2000 i=1,im*km
+2000  q(i,1,IC) = qtmp(i,1)
+4000  continue
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/prather.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/prather.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/prather.F	(revision 984)
@@ -0,0 +1,359 @@
+!
+! $Header$
+!
+      SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt)
+      IMPLICIT NONE
+
+c=======================================================================
+c   Adaptation LMDZ:  A.Armengaud (LGGE)
+c   ----------------
+c
+c   ************************************************
+c   Transport des traceurs par la methode de prather
+c   Ref : 
+c
+c   ************************************************
+c   q,w,pext,pbaru et pbarv : arguments d'entree  pour le s-pg
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iq,nt
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm )
+      REAL masse(iip1,jjp1,llm)
+      REAL q( iip1,jjp1,llm,0:9)
+      REAL w( ip1jmp1,llm )
+      integer ordre,ilim
+
+c   Local:
+c   ------
+      LOGICAL limit
+      real zq(iip1,jjp1,llm)
+      REAL sm ( iip1,jjp1, llm )
+      REAL s0( iip1,jjp1,llm ),  sx( iip1,jjp1,llm )
+      REAL sy( iip1,jjp1,llm ),  sz( iip1,jjp1,llm )
+      REAL sxx( iip1,jjp1,llm)
+      REAL sxy( iip1,jjp1,llm)
+      REAL sxz( iip1,jjp1,llm)
+      REAL syy( iip1,jjp1,llm )
+      REAL syz( iip1,jjp1,llm )
+      REAL szz( iip1,jjp1,llm ),zz
+      INTEGER i,j,l,indice
+      real sxn(iip1),sxs(iip1)
+
+      real sinlon(iip1),sinlondlon(iip1)
+      real coslon(iip1),coslondlon(iip1)
+      real qmin,qmax
+      save qmin,qmax
+      save sinlon,coslon,sinlondlon,coslondlon
+      real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps
+      real masn,mass
+c
+      REAL      SSUM
+      integer ismax,ismin
+      EXTERNAL  SSUM, ismin,ismax
+      logical first
+      save first
+
+      data first/.true./
+      data qmin,qmax/-1.e33,1.e33/
+
+
+c==========================================================================
+c==========================================================================
+c     MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt
+c==========================================================================
+c==========================================================================
+      REAL dt
+c==========================================================================
+      limit = .TRUE.
+ 
+      if(first) then
+         print*,'SCHEMA PRATHER'
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         enddo
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+
+        DO l = 1,llm
+        DO j = 1,jjp1
+        DO i = 1,iip1
+        q( i,j,l,1 )=0.
+        q( i,j,l,2)=0.
+        q( i,j,l,3)=0.
+        q( i,j,l,4)=0.
+        q( i,j,l,5)=0.
+        q( i,j,l,6)=0.
+        q( i,j,l,7)=0.
+        q( i,j,l,8)=0.
+        q( i,j,l,9)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      endif
+c   Fin modif Fred
+
+c *** On calcule la masse d'air en kg
+
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+         sm( i,j,llm+1-l ) =masse(i,j,l)
+         ENDDO
+        ENDDO
+       ENDDO
+
+c *** q contient les qqtes de traceur avant l'advection 
+
+c *** Affectation des tableaux S a partir de Q
+ 
+       DO l = 1,llm
+        DO j = 1,jjp1
+         DO i = 1,iip1
+       s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l)
+       sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l)
+       sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l)
+       sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l)
+       sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l)
+       sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l)
+       sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l)
+       syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l)
+       syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l)
+       szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l)
+         ENDDO
+        ENDDO
+       ENDDO
+c *** Appel des subroutines d'advection en X, en Y et en Z
+c *** Advection avec "time-splitting"
+      
+c-----------------------------------------------------------
+       do indice =1,nt
+       call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        end do
+        do l=1,llm
+        do i=1,iip1
+        sy(i,1,l)=0.
+        sy(i,jjp1,l)=0.
+        enddo
+        enddo
+c---------------------------------------------------------
+       call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+c---------------------------------------------------------
+
+c---------------------------------------------------------
+       do j=1,jjp1
+          do i=1,iip1
+             sz(i,j,1)=0.
+             sz(i,j,llm)=0.
+             sxz(i,j,1)=0.
+             sxz(i,j,llm)=0.
+             syz(i,j,1)=0.
+             syz(i,j,llm)=0.
+             szz(i,j,1)=0.
+             szz(i,j,llm)=0.
+          enddo
+       enddo
+       call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz 
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        do l=1,llm
+        do i=1,iip1
+        sy(i,1,l)=0.
+        sy(i,jjp1,l)=0.
+        enddo
+        enddo
+
+c---------------------------------------------------------
+
+c---------------------------------------------------------
+       call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+c---------------------------------------------------------
+       DO l = 1,llm
+        DO j = 1,jjp1
+             s0( iip1,j,l)=s0( 1,j,l )
+             sx( iip1,j,l)=sx( 1,j,l )
+             sy( iip1,j,l)=sy( 1,j,l )
+             sz( iip1,j,l)=sz( 1,j,l )
+             sxx( iip1,j,l)=sxx( 1,j,l )
+             sxy( iip1,j,l)=sxy( 1,j,l) 
+             sxz( iip1,j,l)=sxz( 1,j,l )
+             syy( iip1,j,l)=syy( 1,j,l )
+             syz( iip1,j,l)=syz( 1,j,l)
+             szz( iip1,j,l)=szz( 1,j,l )
+        ENDDO
+       ENDDO
+       do indice=1,nt
+       call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz
+     .             ,sxx,sxy,sxz,syy,syz,szz,1 )
+        end do
+c---------------------------------------------------------
+c---------------------------------------------------------
+c ***   On repasse les S dans la variable qpr
+c ***   On repasse les S dans la variable q directement 14/10/94
+
+       DO  l = 1,llm
+        DO  j = 1,jjp1
+         DO  i = 1,iip1
+      q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l)
+      q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l)
+      ENDDO
+      ENDDO
+      ENDDO
+
+c---------------------------------------------------------
+c      go to  777
+c   filtrages aux poles
+
+c Traitements specifiques au pole
+
+c   filtrages aux poles
+         DO l=1,llm
+c   filtrages aux poles
+         masn=ssum(iim,sm(1,1,l),1)
+         mass=ssum(iim,sm(1,jjp1,l),1)
+         qpn=ssum(iim,s0(1,1,l),1)/masn
+         qps=ssum(iim,s0(1,jjp1,l),1)/mass
+         dqzpn=ssum(iim,sz(1,1,l),1)/masn
+         dqzps=ssum(iim,sz(1,jjp1,l),1)/mass
+         do i=1,iip1
+          q( i,1,llm+1-l,3)=dqzpn
+          q( i,jjp1,llm+1-l,3)=dqzps
+          q( i,1,llm+1-l,0)=qpn
+          q( i,jjp1,llm+1-l,0)=qps
+         enddo
+c       enddo
+c         print*,'qpn',qpn,'qps',qps
+c          print*,'dqzpn',dqzpn,'dqzps',dqzps
+c       enddo
+           dyn1=0.
+           dys1=0.
+           dyn2=0.
+           dys2=0.
+        do i=1,iim
+        zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0)
+        dyn1=dyn1+sinlondlon(i)*zz
+        dyn2=dyn2+coslondlon(i)*zz
+        zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l)
+        dys1=dys1+sinlondlon(i)*zz
+        dys2=dys2+coslondlon(i)*zz
+        enddo
+         do i=1,iim
+         q(i,1,llm+1-l,2)=
+     $   (sinlon(i)*dyn1+coslon(i)*dyn2)/2.
+         q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)
+     $          +q(i,1,llm+1-l,2)
+         q(i,jjp1,llm+1-l,2)=
+     $   (sinlon(i)*dys1+coslon(i)*dys2)/2.
+         q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0)
+     $      -q(i,jjp1,llm+1-l,2)
+         enddo
+      q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0)
+      q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0)
+      do i=1,iim
+      sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0)
+      sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0)
+      enddo
+      sxn(iip1)=sxn(1)
+      sxs(iip1)=sxs(1)
+      do i=1,iim
+      q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1))
+      q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1))
+      END DO
+      q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1)
+      q(1,jjp1,llm+1-l,1)=
+     $   q(iip1,jjp1,llm+1-l,1)
+        enddo
+         do l=1,llm
+           do i=1,iim
+            q( i,1,llm+1-l,4)=0.
+            q( i,jjp1,llm+1-l,4)=0.
+            q( i,1,llm+1-l,5)=0.
+            q( i,jjp1,llm+1-l,5)=0.
+            q( i,1,llm+1-l,6)=0.
+            q( i,jjp1,llm+1-l,6)=0.
+            q( i,1,llm+1-l,7)=0.
+            q( i,jjp1,llm+1-l,7)=0.
+            q( i,1,llm+1-l,8)=0.
+            q( i,jjp1,llm+1-l,8)=0.
+            q( i,1,llm+1-l,9)=0.
+            q( i,jjp1,llm+1-l,9)=0.
+          enddo
+         ENDDO
+
+777      continue
+c
+c   bouclage en longitude
+      do l=1,llm
+      do j=1,jjp1
+      q(iip1,j,l,0)=q(1,j,l,0)
+      q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0)
+      q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1)
+      q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2)
+      q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3)
+      q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4)
+      q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5)
+      q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6)
+      q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7)
+      q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8)
+      q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9)
+      enddo
+      enddo
+        DO l = 1,llm
+    	 DO j = 2,jjm
+           DO i = 1,iip1
+         IF (q(i,j,l,0).lt.0.)  THEN
+         PRINT*,'------------ BIP-----------' 
+         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0),
+     $          q(i,j-1,l,0)
+         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2),
+     $   q(i,j-1,l,2)   
+         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+c    		     PRINT*,' PBL EN SORTIE D'' ADVZP'
+                     q(i,j,l,0)=0.
+c                  STOP
+               ENDIF
+           ENDDO
+         ENDDO
+         do j=1,jjp1,jjm
+         do i=1,iip1
+               IF (q(i,j,l,0).lt.0.)  THEN
+               PRINT*,'------------ BIP 2-----------'
+         PRINT*,'S0(',i,j,l,')=',q(i,j,l,0)
+         PRINT*,'SX(',i,j,l,')=',q(i,j,l,1)
+         PRINT*,'SY(',i,j,l,')=',q(i,j,l,2)
+         PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3)
+
+                     q(i,j,l,0)=0.
+c                  STOP
+               ENDIF
+         enddo
+         enddo
+        ENDDO
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/pres2lev.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/pres2lev.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/pres2lev.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+c******************************************************
+      SUBROUTINE   pres2lev(varo,varn,lmo,lmn,po,pn,
+     %                      ni,nj)
+c
+c interpolation lineaire pour passer
+c a une nouvelle discretisation verticale pour
+c les variables de GCM
+c Francois Forget (01/1995)
+c 
+c MOdif remy roca 12/97 pour passer de pres2sig
+c**********************************************************
+
+      IMPLICIT NONE
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+
+       INTEGER lmo ! dimensions ancienne couches (input)
+       INTEGER lmn ! dimensions nouvelle couches (input)
+       INTEGER lmomx ! dimensions ancienne couches (input)
+       INTEGER lmnmx ! dimensions nouvelle couches (input)
+
+       parameter(lmomx=10000,lmnmx=10000)
+
+        real po(lmo)! niveau de pression en millibars
+        real pn(ni,nj,lmn) ! niveau de pression en pascals
+
+       INTEGER i,j,Nhoriz,ni,nj ! nombre de point horizontale (input)
+
+       REAL varo(ni,nj,lmo) ! var dans l'ancienne grille (input)
+       REAL varn(ni,nj,lmn) ! var dans la nouvelle grille (output)
+
+       real zvaro(lmomx),zpo(lmomx)
+
+c Autres variables
+c """"""""""""""""
+       INTEGER n, ln ,lo 
+       REAL coef
+
+c run
+c ====
+        do i=1,ni
+        do j=1,nj
+c a chaque point de grille correspond un nouveau sigma old
+c qui vaut pres(l)/ps(i,j)
+           do lo=1,lmo
+              zpo(lo)=po(lmo+1-lo)
+              zvaro(lo)=varo(i,j,lmo+1-lo)
+           enddo
+        
+           do ln=1,lmn
+              if (pn(i,j,ln).ge.zpo(1))then
+                 varn(i,j,ln) =  zvaro(1)
+              else if (pn(i,j,ln).le.zpo(lmo)) then
+                 varn(i,j,ln) =  zvaro(lmo)
+              else
+                 do lo=1,lmo-1 
+                    if ( (pn(i,j,ln).le.zpo(lo)).and.
+     &                 (pn(i,j,ln).gt.zpo(lo+1)) )then
+                       coef=(pn(i,j,ln)-zpo(lo))
+     &                 /(zpo(lo+1)-zpo(lo))
+                       varn(i,j,ln)=zvaro(lo)
+     &                 +coef*(zvaro(lo+1)-zvaro(lo))
+c       print*,'pn(',ln,')=',pn(i,j,ln),varn(i,j,ln)
+                    end if
+                 enddo           
+              endif
+           enddo
+
+        enddo
+        enddo
+      return
+      end    
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/pression.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/pression.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/pression.F	(revision 984)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+      SUBROUTINE pression( ngrid, ap, bp, ps, p )
+c
+
+c      Auteurs : P. Le Van , Fr.Hourdin  .
+
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+      INTEGER ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      DO    l    = 1, llmp1
+        DO  ij   = 1, ngrid
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+   
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/pression_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/pression_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/pression_p.F	(revision 984)
@@ -0,0 +1,40 @@
+      SUBROUTINE pression_p( ngrid, ap, bp, ps, p )
+      USE parallel
+c
+
+c      Auteurs : P. Le Van , Fr.Hourdin  .
+
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+      INTEGER ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      INTEGER ijb,ije
+
+      
+      ijb=ij_begin-iip1
+      ije=ij_end+2*iip1
+      
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+      DO    l    = 1, llmp1
+        DO  ij   = ijb, ije
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT   
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/profvert.def
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/profvert.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/profvert.def	(revision 984)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+nom_courbes=F
+titre=/home/hourdin/LMDZ4/libf/dyn3d
+xinf=0.
+xsup=669.
+yinf=6.5
+ysup=10.5
+axtxtx=sols
+axtxty=pressure (mb)
+pathcham=.
+lstyles=1 9999
+linewidth=.2
+lcolors=1 9999
+frwidth=.5
+repery0=T
+txtheight=2.5
+freecoord=/d2/hourdin/Ames/saison.def
+
+determination du champ physique
+xlength=195.
+ylength=105.
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/psextbar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/psextbar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/psextbar.F	(revision 984)
@@ -0,0 +1,107 @@
+!
+! $Header$
+!
+      SUBROUTINE psextbar ( ps, psexbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c **********************************************************************
+c
+c         ps          est un  argum. d'entree  pour le s-pg ..
+c         psexbarxy   est un  argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )
+
+      INTEGER  l, ij
+c
+
+      DO ij = 1, ip1jmp1
+       pext(ij) = ps(ij) * aire(ij)
+      ENDDO
+
+
+      DO     5     ij = 1, ip1jm - 1
+      psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     psexbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      psexbarxy( ij ) = psexbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/q_sat.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/q_sat.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/q_sat.F	(revision 984)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+c
+c
+
+      subroutine q_sat(np,temp,pres,qsat)
+c
+      IMPLICIT none
+c======================================================================
+c Autheur(s): Z.X. Li (LMD/CNRS)
+c  reecriture vectorisee par F. Hourdin.
+c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+c======================================================================
+c Arguments:
+c kelvin---input-R: temperature en Kelvin
+c millibar--input-R: pression en mb
+c
+c q_sat----output-R: vapeur d'eau saturante en kg/kg
+c======================================================================
+c
+      integer np
+      REAL temp(np),pres(np),qsat(np)
+c
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+c
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+c
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+c
+      REAL rtt
+      PARAMETER (rtt=273.16)
+c
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+
+      real zqsat
+      integer ip
+c
+C     ------------------------------------------------------------------
+c
+c
+
+      do ip=1,np
+
+c      write(*,*)'kelvin,millibar=',kelvin,millibar
+c       write(*,*)'temp,pres=',temp(ip),pres(ip)
+c
+         IF (temp(ip) .LE. rtt) THEN
+            r3es = r3ies
+            r4es = r4ies
+         ELSE
+            r3es = r3les
+            r4es = r4les
+         ENDIF
+c
+         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+         zqsat=MIN(0.5,ZQSAT)
+         zqsat=zqsat/(1.-retv *zqsat)
+c
+         qsat(ip)= zqsat
+c      write(*,*)'qsat=',qsat(ip)
+
+      enddo
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/qminimum_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/qminimum_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/qminimum_p.F	(revision 984)
@@ -0,0 +1,87 @@
+      SUBROUTINE qminimum_p( q,nq,deltap )
+      USE parallel
+      IMPLICIT none
+c
+c  -- Objet : Traiter les valeurs trop petites (meme negatives)
+c             pour l'eau vapeur et l'eau liquide
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+c
+      INTEGER nq
+      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide
+c
+c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+c            parametres seuil_vap, seuil_liq soient pareilles a celles 
+c            qui  sont utilisees dans la routine    ADDFI       )
+c     .................................................................
+c
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+c
+      REAL SSUM
+      EXTERNAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+      INTEGER ijb,ije
+c
+c Quand l'eau liquide est trop petite (ou negative), on prend
+c l'eau vapeur de la meme couche et la convertit en eau liquide
+c (sans changer la temperature !)
+c
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO 1000 k = 1, llm
+      DO 1040 i = ijb, ije
+            zx_defau      = AMAX1( seuil_liq - q(i,k,iq_liq), 0.0 )
+            q(i,k,iq_vap) = q(i,k,iq_vap) - zx_defau
+            q(i,k,iq_liq) = q(i,k,iq_liq) + zx_defau
+ 1040 CONTINUE
+ 1000 CONTINUE
+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
+      iq = iq_vap
+c
+      DO k = llm, 2, -1
+ccc      zx_abc = dpres(k) / dpres(k-1)
+      DO i = ijb, ije
+         zx_abc = deltap(i,k)/deltap(i,k-1)
+         zx_defau    = AMAX1( seuil_vap - q(i,k,iq), 0.0 )
+         q(i,k-1,iq) =  q(i,k-1,iq) - zx_defau * zx_abc
+         q(i,k,iq)   =  q(i,k,iq)   + zx_defau  
+      ENDDO
+      ENDDO
+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
+      DO i = ijb, ije
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+      ENDDO
+      pompe = SSUM(ije-ijb+1,zx_pump(ijb),1)
+      IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN
+         WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
+         DO i = ijb, ije
+            IF (zx_pump(i).GT.0.0) THEN
+               imprim = imprim + 1
+               PRINT*,'  en ',i,zx_pump(i)
+            ENDIF
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ran1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ran1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ran1.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      FUNCTION RAN1(IDUM)
+      DIMENSION R(97)
+      save r
+      save iff,ix1,ix2,ix3
+      PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6)
+      PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6)
+      PARAMETER (M3=243000,IA3=4561,IC3=51349)
+      DATA IFF /0/
+      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)=(FLOAT(IX1)+FLOAT(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)PAUSE
+      RAN1=R(J)
+      R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/read_reanalyse.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/read_reanalyse.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/read_reanalyse.F	(revision 984)
@@ -0,0 +1,544 @@
+!
+! $Header$
+!
+c
+c
+      subroutine read_reanalyse(timestep,psi
+     s   ,u,v,t,q,masse,ps,mode,nlevnc)
+
+c   mode=0 variables naturelles
+c   mode=1 variabels GCM
+
+       USE parallel
+c -----------------------------------------------------------------
+c   Declarations
+c -----------------------------------------------------------------
+      IMPLICIT NONE
+
+c common
+c ------
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "guide.h"
+
+
+c arguments
+c ---------
+      integer nlevnc
+      integer timestep,mode,l
+
+      real psi(iip1,jjp1)
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+
+
+c local
+c -----
+      integer ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps
+      integer ncidpl
+      integer varidpl,ncidQ,varidQ
+      save ncidpl,ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps
+      save varidpl,ncidQ,varidQ
+
+      real*4 unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
+      real*4 tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
+      real*4 Qnc(iip1,jjp1,nlevnc)
+      real*4 pl(nlevnc),presnc(iip1,jjp1,nlevnc)
+
+      integer start(4),count(4),status
+
+      real rcode
+      logical first
+      save first
+      INTEGER ierr
+
+      data first/.true./
+
+
+
+c -----------------------------------------------------------------
+c   Initialisation de la lecture des fichiers
+c -----------------------------------------------------------------
+      if (first) then
+           ncidpl=-99
+           print*,'Intitialisation de read reanalsye'
+
+c Vent zonal
+            if (guide_u) then
+               ncidu=NCOPN('u.nc',NCNOWRIT,rcode)
+               varidu=NCVID(ncidu,'UWND',rcode)
+               print*,'ncidu,varidu',ncidu,varidu
+               if (ncidpl.eq.-99) ncidpl=ncidu
+            endif
+
+c Vent meridien
+            if (guide_v) then
+               ncidv=NCOPN('v.nc',NCNOWRIT,rcode)
+               varidv=NCVID(ncidv,'VWND',rcode)
+               print*,'ncidv,varidv',ncidv,varidv
+               if (ncidpl.eq.-99) ncidpl=ncidu
+            endif
+           
+
+c Temperature
+            if (guide_T) then
+               ncidt=NCOPN('T.nc',NCNOWRIT,rcode)
+               varidt=NCVID(ncidt,'AIR',rcode)
+               print*,'ncidt,varidt',ncidt,varidt
+               if (ncidpl.eq.-99) ncidpl=ncidu
+            endif
+            
+c Humidite
+            if (guide_Q) then
+               ncidQ=NCOPN('hur.nc',NCNOWRIT,rcode)
+               varidQ=NCVID(ncidQ,'RH',rcode)
+               print*,'ncidQ,varidQ',ncidQ,varidQ
+               if (ncidpl.eq.-99) ncidpl=ncidu
+            endif
+            
+c Pression de surface
+            if (guide_P) then
+               ncidps=NCOPN('ps.nc',NCNOWRIT,rcode)
+               varidps=NCVID(ncidps,'SP',rcode)
+               print*,'ncidps,varidps',ncidps,varidps
+            endif
+            
+c Coordonnee vertcale
+            if (ncep) then
+               print*,'Vous etes entrain de lire des donnees NCEP'
+               varidpl=NCVID(ncidpl,'LEVEL',rcode)
+            else
+               print*,'Vous etes entrain de lire des donnees ECMWF'
+               varidpl=NCVID(ncidpl,'PRESSURE',rcode)
+            endif
+            print*,'ncidu,varidpl',ncidu,varidpl
+
+      endif
+
+      print*,'ok1'
+
+c -----------------------------------------------------------------
+c   lecture des champs u, v, T, ps
+c -----------------------------------------------------------------
+
+c  niveaux de pression
+c  -------------------
+
+      print*,'WARNING!!! Il n y a pas de test de coherence'
+      print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,pl)
+#else
+      status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,pl)
+#endif
+     
+c  passage en pascal
+      pl(:)=100.*pl(:)
+c  passage des presions sur une grille 3D
+      do l=1,nlevnc
+         presnc(:,:,l)=pl(l)
+      enddo
+      if(first) then
+         do l=1,nlevnc
+            print*,'PL(',l,')=',pl(l)
+         enddo
+      endif
+
+
+c  dimensions pour les champs scalaires et le vent zonal
+c  -----------------------------------------------------
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=timestep
+
+      count(1)=iip1
+      count(2)=jjp1
+      count(3)=nlevnc
+      count(4)=1
+
+
+c mise a zero des tableaux 
+c ------------------------
+       unc(:,:,:)=0.
+       vnc(:,:,:)=0.
+       tnc(:,:,:)=0.
+       Qnc(:,:,:)=0.
+
+c  Vent zonal
+c  ----------
+
+      if (guide_u) then
+         print*,'avant la lecture de UNCEP nd de niv:',nlevnc
+
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unc)
+#else
+         status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unc)
+#endif
+c     call dump2d(iip1,jjp1,unc,'VENT NCEP   ')
+c     call dump2d(iip1,40,unc(1,1,nlevnc),'VENT NCEP   ')
+         print*,'WARNING!!! Correction bidon pour palier a un '
+         print*,'probleme dans la creation des fichiers nc'
+         call correctbid(iim,jjp1*nlevnc,unc)
+         call dump2d(iip1,jjp1,unc,'UNC COUCHE 1 ')
+      endif
+
+c  Temperature
+c  -----------
+
+      print*,'ncidt=',ncidt,'varidt=',varidt,'start=',start
+      print*,'count=',count
+      if (guide_T) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnc)
+#else
+         status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnc)
+#endif
+         call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 AAA ')
+         call correctbid(iim,jjp1*nlevnc,tnc)
+         call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 BBB ')
+      endif
+
+c  Humidite
+c  --------
+
+      if (guide_Q) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,Qnc)
+#else
+         status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,Qnc)
+#endif
+         call correctbid(iim,jjp1*nlevnc,Qnc)
+         call dump2d(iip1,jjp1,Qnc,'QNC COUCHE 1 ')
+      endif
+
+      count(2)=jjm
+c  Vent meridien
+c  -------------
+
+      if (guide_v) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnc)
+#else
+         status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnc)
+#endif
+         call correctbid(iim,jjm*nlevnc,vnc)
+         call dump2d(iip1,jjm,vnc,'VNC COUCHE 1 ')
+      endif
+
+      start(3)=timestep
+      start(4)=0
+      count(2)=jjp1
+      count(3)=1
+      count(4)=0
+
+c  Pression de surface
+c  -------------------
+
+      if (guide_P) then
+#ifdef NC_DOUBLE
+         status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnc)
+#else
+         status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnc)
+#endif
+         call dump2d(iip1,jjp1,psnc,'PSNC COUCHE 1 ')
+         call correctbid(iim,jjp1,psnc)
+      endif
+
+
+
+c -----------------------------------------------------------------
+c  Interpollation verticale sur les niveaux modele
+c -----------------------------------------------------------------
+      call reanalyse2nat(nlevnc,psi,unc,vnc,tnc,Qnc,psnc,pl,u,v,t,Q
+     s    ,ps,masse,pk)
+
+      call dump2d(iip1,jjm,v,'V COUCHE APRES ')
+
+
+c -----------------------------------------------------------------
+c  Passage aux variables du modele (vents covariants, temperature
+c  potentielle et humidite specifique)
+c -----------------------------------------------------------------
+      call nat2gcm(u,v,t,Q,pk,u,v,t,Q)
+      print*,'TIMESTEP ',timestep
+      if(mode.ne.1) stop'mode pas egal 0'
+c     call dump2d(iip1,jjm,v,'VCOV COUCHE 1 ')
+
+c   Lignes introduites a une epoque pour un probleme oublie...
+c     do l=1,llm
+c        do i=1,iip1
+c           v(i,1,l)=0.
+c           v(i,jjm,l)=0.
+c        enddo
+c     enddo
+      first=.false.
+
+      return
+      end
+
+
+c===========================================================================
+      subroutine reanalyse2nat(nlevnc,psi
+     s   ,unc,vnc,tnc,qnc,psnc,pl,u,v,t,q
+     s   ,ps,masse,pk)
+c===========================================================================
+
+c -----------------------------------------------------------------
+c   Inversion Nord/sud de la grille + interpollation sur les niveaux
+c   verticaux du modele.
+c -----------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "guide.h"
+
+      integer nlevnc
+      real psi(iip1,jjp1)
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),ps(iip1,jjp1),q(iip1,jjp1,llm)
+
+      real pl(nlevnc)
+      real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
+      real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
+      real qnc(iip1,jjp1,nlevnc)
+
+      real zu(iip1,jjp1,llm),zv(iip1,jjm,llm)
+      real zt(iip1,jjp1,llm),zq(iip1,jjp1,llm)
+
+      real pext(iip1,jjp1,llm)
+      real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm)
+      real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm)
+      real plsnc(iip1,jjp1,llm)
+
+      REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm)
+      real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1)
+      real pkf(iip1,jjp1,llm)
+      real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm)
+      real prefkap,unskap
+
+
+      integer i,j,l
+
+
+c -----------------------------------------------------------------
+c   calcul de la pression au milieu des couches.
+c -----------------------------------------------------------------
+
+      CALL pression( ip1jmp1, ap, bp, psi, p )
+      call massdair(p,masse)
+      CALL exner_hyb(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf)
+
+c    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+      unskap=1./kappa
+      prefkap =  preff  ** kappa
+c     PRINT *,' Pref kappa unskap  ',preff,kappa,unskap
+      DO l = 1, llm
+       DO j=1,jjp1
+        DO i =1, iip1
+        pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+        ENDDO
+       ENDDO
+       ENDDO
+
+
+c -----------------------------------------------------------------
+c   calcul des pressions pour les grilles u et v
+c -----------------------------------------------------------------
+
+      do l=1,llm
+      do j=1,jjp1
+         do i=1,iip1
+            pext(i,j,l)=pls(i,j,l)*aire(i,j)
+         enddo
+      enddo
+      enddo
+      call massbar(pext, pbarx, pbary )
+      do l=1,llm
+      do j=1,jjp1
+         do i=1,iip1
+            plunc(i,jjp1+1-j,l)=pbarx(i,j,l)/aireu(i,j)
+            plsnc(i,jjp1+1-j,l)=pls(i,j,l)
+         enddo
+      enddo
+      enddo
+      do l=1,llm
+      do j=1,jjm
+         do i=1,iip1
+            plvnc(i,jjm+1-j,l)=pbary(i,j,l)/airev(i,j)
+         enddo
+      enddo
+      enddo
+
+c -----------------------------------------------------------------
+
+      if (guide_P) then
+      do j=1,jjp1
+         do i=1,iim
+            ps(i,j)=psnc(i,jjp1+1-j)
+         enddo
+         ps(iip1,j)=ps(1,j)
+      enddo
+      endif
+
+
+c -----------------------------------------------------------------
+      call pres2lev(unc,zu,nlevnc,llm,pl,plunc,iip1,jjp1)
+      call pres2lev(vnc,zv,nlevnc,llm,pl,plvnc,iip1,jjm )
+      call pres2lev(tnc,zt,nlevnc,llm,pl,plsnc,iip1,jjp1)
+      call pres2lev(qnc,zq,nlevnc,llm,pl,plsnc,iip1,jjp1)
+
+c     call dump2d(iip1,jjp1,ps,'PS    ')
+c     call dump2d(iip1,jjp1,psu,'PS    ')
+c     call dump2d(iip1,jjm,psv,'PS    ')
+c  Inversion Nord/Sud
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iim
+               u(i,j,l)=zu(i,jjp1+1-j,l)
+               t(i,j,l)=zt(i,jjp1+1-j,l)
+               q(i,j,l)=zq(i,jjp1+1-j,l)
+            enddo
+            u(iip1,j,l)=u(1,j,l)
+            t(iip1,j,l)=t(1,j,l)
+            q(iip1,j,l)=q(1,j,l)
+         enddo
+      enddo
+
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               v(i,j,l)=zv(i,jjm+1-j,l)
+            enddo
+            v(iip1,j,l)=v(1,j,l)
+         enddo
+      enddo
+
+      return
+      end
+
+c===========================================================================
+      subroutine nat2gcm(u,v,t,rh,pk,ucov,vcov,teta,q)
+c===========================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "guide.h"
+
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),pk(iip1,jjp1,llm),rh(iip1,jjp1,llm)
+      real ps(iip1,jjp1)
+
+      real ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm),q(iip1,jjp1,llm)
+
+      real pres(iip1,jjp1,llm),qsat(iip1,jjp1,llm)
+
+      real unskap
+
+      integer i,j,l
+
+
+      print*,'Entree dans nat2gcm'
+c    ucov(:,:,:)=0.
+c    do l=1,llm
+c       ucov(:,2:jjm,l)=u(:,2:jjm,l)*cu(:,2:jjm)
+c    enddo
+c    ucov(iip1,:,:)=ucov(1,:,:)
+
+c    teta(:,:,:)=t(:,:,:)*cpp/pk(:,:,:)
+c    teta(iip1,:,:)=teta(1,:,:)
+     
+c   calcul de ucov et de la temperature potentielle
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iim
+               ucov(i,j,l)=u(i,j,l)*cu(i,j)
+               teta(i,j,l)=t(i,j,l)*cpp/pk(i,j,l)
+            enddo
+            ucov(iip1,j,l)=ucov(1,j,l)
+            teta(iip1,j,l)=teta(1,j,l)
+         enddo
+         do i=1,iip1
+            ucov(i,1,l)=0.
+            ucov(i,jjp1,l)=0.
+            teta(i,1,l)=teta(1,1,l)
+            teta(i,jjp1,l)=teta(1,jjp1,l)
+         enddo
+      enddo
+
+c   calcul de ucov
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               vcov(i,j,l)=v(i,j,l)*cv(i,j)
+            enddo
+            vcov(iip1,j,l)=vcov(1,j,l)
+         enddo
+      enddo
+
+c     call dump2d(iip1,jjp1,teta,'TETA EN BAS   ')
+c     call dump2d(iip1,jjp1,teta(1,1,llm),'TETA EN HAUT   ')
+
+c  Humidite relative -> specifique
+c  -------------------------------
+      if (1.eq.0) then
+c   FINALEMENT ON GUIDE EN HUMIDITE RELATIVE
+      print*,'calcul de unskap'
+      unskap   = 1./ kappa
+      print*,'calcul de pres'
+      pres(:,:,:)=preff*(pk(:,:,:)/cpp)**unskap
+      print*,'calcul de qsat'
+      call q_sat(iip1*jjp1*llm,t,pres,qsat)
+      print*,'calcul de q'
+c   ATTENTION : humidites relatives en %
+      rh(:,:,:)=max(rh(:,:,:)*0.01,1.e-6)
+      q(:,:,:)=qsat(:,:,:)*rh(:,:,:)
+      print*,'calcul de q OK'
+
+      call dump2d(iip1,jjp1,pres,'PRESSION PREMIERE COUCHE   ')
+      call dump2d(iip1,jjp1,q,'HUMIDITE SPECIFIQUE COUCHE 1   ') 
+      endif
+
+
+      return
+      end
+
+
+
+c===========================================================================
+      subroutine correctbid(iim,nl,x)
+c===========================================================================
+      integer iim,nl
+      real x(iim+1,nl)
+      integer i,l
+      real zz
+
+      do l=1,nl
+         do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+c              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+      enddo
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat.F	(revision 984)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE rotat (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_nfil.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_nfil.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_nfil.F	(revision 984)
@@ -0,0 +1,49 @@
+!
+! $Header$
+!
+      SUBROUTINE rotat_nfil (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van 
+c**************************************************************
+c.          Calcule le rotationnel  non filtre   ,
+c      a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_nfil_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_nfil_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_nfil_p.F	(revision 984)
@@ -0,0 +1,52 @@
+      SUBROUTINE rotat_nfil_p (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van 
+c**************************************************************
+c.          Calcule le rotationnel  non filtre   ,
+c      a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+      INTEGER :: ijb,ije
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO  10 l = 1,klevel
+c
+        DO   ij = ijb, ije - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = ijb+iip1-1, ije, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotat_p.F	(revision 984)
@@ -0,0 +1,63 @@
+      SUBROUTINE rotat_p (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+      INTEGER :: ijb,ije
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO  10 l = 1,klevel
+c
+        DO   ij = ijb, ije - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = ijb+iip1-1, ije, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+        DO l = 1, klevel
+          DO ij = ijb, ije
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatf.F	(revision 984)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      SUBROUTINE rotatf (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatf_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatf_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatf_p.F	(revision 984)
@@ -0,0 +1,67 @@
+      SUBROUTINE rotatf_p (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+      INTEGER :: ijb,ije,jjb,jje
+c
+c
+      ijb=ij_begin
+      ije=ij_end
+      if(pole_sud) ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO  10 l = 1,klevel
+c
+        DO   ij = ijb, ije - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = ijb+iip1-1, ije, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+c$OMP END DO NOWAIT
+        jjb=jj_begin
+        jje=jj_end
+        if (pole_sud) jje=jj_end-1
+        CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2, 2, .FALSE., 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+        DO l = 1, klevel
+          DO ij = ijb, ije
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatst.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatst.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/rotatst.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      SUBROUTINE rotatst (klevel,x, y, rot )
+c
+c  P. Le Van
+c
+c    *****************************************************************
+c     .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y ..
+c         x  et  y etant des composantes  covariantes  .....
+c    *****************************************************************
+c        x  et y     sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+      INTEGER klevel
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+      INTEGER  l, ij
+c
+c
+      DO 5 l = 1,klevel
+c
+      DO 1 ij = 1, ip1jm - 1
+      rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   +
+     *                 x(ij +iip1, l )  -  x( ij,l )  )
+   1  CONTINUE
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim,l )
+   2  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/serre.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/serre.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/serre.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+c
+c
+c..include serre.h
+c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , 
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/sort.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/sort.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/sort.F	(revision 984)
@@ -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: LMDZ4/tags/LF_20080728/libf/dyn3dpar/sortvarc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/sortvarc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/sortvarc.F	(revision 984)
@@ -0,0 +1,165 @@
+!
+! $Header$
+!
+      SUBROUTINE sortvarc
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       ge(:)=dp(:)*dp(:)
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot  = SSUM(     llm, etotl, 1 )
+      ztot  = SSUM(     llm, ztotl, 1 )
+      stot  = SSUM(     llm, stotl, 1 )
+      rmsv  = SSUM(     llm, rmsvl, 1 )
+      ang   = SSUM(     llm,  angl, 1 )
+
+      rday = FLOAT(INT ( day_ini + time ))
+c
+      IF(ptot0.eq.0.)  THEN
+         PRINT 3500, itau, rday, heure,time
+         PRINT*,'WARNING!!! On recalcule les valeurs initiales de :'
+         PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
+         PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+         etot0 = etot
+         ptot0 = ptot
+         ztot0 = ztot
+         stot0 = stot
+         ang0  = ang
+      END IF
+
+      etot= etot/etot0
+      rmsv= SQRT(rmsv/ptot)
+      ptot= ptot/ptot0
+      ztot= ztot/ztot0
+      stot= stot/stot0
+      ang = ang /ang0
+
+
+      PRINT 3500, itau, rday, heure, time
+      PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+
+      RETURN
+
+3500   FORMAT('0'10(1h*),4x,'pas'i7,5x,'jour'f5.0,'heure'f5.1,4x 
+     *   ,'date',f10.5,4x,10(1h*))
+4000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie'
+     * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB  '
+     .  ,f10.6,e13.6,5f10.3/
+     * )
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/sortvarc0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/sortvarc0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/sortvarc0.F	(revision 984)
@@ -0,0 +1,141 @@
+!
+! $Header$
+!
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      REAL       SSUM
+      integer  ismin,ismax
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       ge=dp*dp
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot0  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot0  = SSUM(     llm, etotl, 1 )
+      ztot0  = SSUM(     llm, ztotl, 1 )
+      stot0  = SSUM(     llm, stotl, 1 )
+      rmsv   = SSUM(     llm, rmsvl, 1 )
+      ang0   = SSUM(     llm,  angl, 1 )
+
+      rday = FLOAT(INT ( day_ini + time ))
+c
+      PRINT 3500, itau, rday, heure, time
+      PRINT *, ptot0,etot0,ztot0,stot0,ang0
+
+3500   FORMAT('0',10(1h*),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x 
+     *   ,'date',f10.5,4x,10(1h*))
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/spline.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/spline.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/spline.F	(revision 984)
@@ -0,0 +1,79 @@
+!
+! $Header$
+!
+      subroutine spline(x,y,n,yp1,ypn,y2)
+     
+c
+     
+c     Routine to set up the interpolating function for a cubic spline
+     
+c     interpolation (see "Numerical Recipes" for details).
+     
+c
+	  implicit real (a-h,o-z)
+	  implicit integer (i-n)
+     
+      parameter(nllm=4096)
+     
+      dimension x(n),y(n),y2(n),u(nllm)
+     
+c
+c	write(6,*)(x(i),i=1,n)
+c	write(6,*)(y(i),i=1,n)
+     
+      if(yp1.gt.0.99E30) then
+c the lower boundary condition is set
+       y2(1)=0.
+c either to be "natural"
+       u(1)=0.
+     
+      else
+c or else to have a specified first
+       y2(1)=-0.5
+c derivative
+       u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+     
+      end if
+     
+      do 11 i=2,n-1
+c decomposition loop of the tridiagonal
+       sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+c algorithm. Y2 and U are used
+       p=sig*y2(i-1)+2.
+c for temporary storage of the decompo-
+       y2(i)=(sig-1.)/p
+c sed factors
+       u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
+     
+     . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+     
+ 11   continue
+     
+      if(ypn.gt.0.99E30) then
+c the upper boundary condition is set
+       qn=0.
+c either to be "natural"
+       un=0.
+     
+      else
+c or else to have a specified first
+       qn=0.5
+c derivative
+       un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+     
+      end if
+     
+      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+     
+      do 12 k=n-1,1,-1
+c this is the backsubstitution loop of
+       y2(k)=y2(k)*y2(k+1)+u(k)
+c the tridiagonal algorithm
+ 12   continue
+     
+c
+     
+      return
+     
+      end
+     
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/splint.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/splint.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/splint.F	(revision 984)
@@ -0,0 +1,56 @@
+!
+! $Header$
+!
+     
+      SUBROUTINE splint(xa,ya,y2a,n,x,y)
+     
+c
+c     Routine to compute a cubic-spline interpolated value Y given the
+c     value of X, the arrays XA, YA and the 2nd derivative array Y2A
+c     computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details
+c
+     
+      IMPLICIT REAL (a-h,o-z)
+      IMPLICIT INTEGER (i-n)
+      DIMENSION xa(n),ya(n),y2a(n)
+     
+      kl0=1
+     
+      khi=n
+c means of bisection
+ 1    IF(khi-kl0.gt.1) THEN
+     
+       k=(khi+kl0)/2
+     
+       IF(xa(k).gt.x) THEN
+     
+        khi=k
+     
+       ELSE
+     
+        kl0=k
+     
+       END IF
+     
+       GO TO 1
+     
+      END IF
+c KL0 and KHI now bracket the X
+      h=xa(khi)-xa(kl0)
+     
+      IF(h.eq.0.0) STOP
+      a=(xa(khi)-x)/h
+c evaluation of cubic spline polynomial
+      b=(x-xa(kl0))/h
+     
+      y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2)
+     
+     ./6.
+     
+c
+     
+      RETURN
+     
+      END
+     
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/startvar.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/startvar.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/startvar.F	(revision 984)
@@ -0,0 +1,1185 @@
+!
+! $Header$
+!
+C
+C
+      MODULE startvar
+    !
+    !
+    !      There are three ways to access data from the database of atmospheric data which 
+    !       can be used to initialize the model. This depends on the type of field which needs 
+    !       to be extracted. In any case the call should come after a restget and should be of the type :
+    !                CALL startget(...)
+    !
+    !       We will details the possible arguments to startget here :
+    !
+    !        - A 2D variable on the dynamical grid :
+    !           CALL startget(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar )             
+    !
+    !        - A 1D variable on the physical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         - A 3D variable on the dynamical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         There is special constraint on the atmospheric data base except that the 
+    !         the data needs to be in netCDF and the variables should have the the following 
+    !        names in the file :
+    !
+    !      'RELIEF'  : High resolution orography 
+    !       'ST'            : Surface temperature
+    !       'CDSW'     : Soil moisture
+    !       'Z'               : Surface geopotential
+    !       'SP'            : Surface pressure
+    !        'U'              : East ward wind
+    !        'V'              : Northward wind
+    !        'TEMP'             : Temperature
+    !        'R'             : Relative humidity
+    !      
+      USE ioipsl
+    !
+    !
+      IMPLICIT NONE
+    !
+    !
+      PRIVATE
+      PUBLIC startget
+    !
+    !
+      INTERFACE startget
+        MODULE PROCEDURE startget_phys2d, startget_phys1d, startget_dyn
+      END INTERFACE
+    !
+      INTEGER, SAVE :: fid_phys, fid_dyn
+      INTEGER, SAVE  :: iml_phys, iml_rel, iml_dyn
+      INTEGER, SAVE :: jml_phys,  jml_rel, jml_dyn
+      INTEGER, SAVE ::  llm_dyn, ttm_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lon_phys, lon_rug,
+     . lon_alb, lon_rel, lon_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lat_phys, lat_rug,
+     . lat_alb, lat_rel, lat_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:)  :: levdyn_ini
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: relief, zstd, zsig,
+     . zgam, zthe, zpic, zval
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rugo, masque, phis
+    !
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: tsol, qsol, psol_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)  ::   var_ana3d
+    !
+      CONTAINS
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in,
+     . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu )
+    !
+    !    There is a big mess with the size in logitude, should it be iml or iml+1.
+    !    I have chosen to use the iml+1 as an argument to this routine and we declare
+    !   internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. 
+    !  A convention is required.
+    !
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(iml,jml)
+      REAL, INTENT(in) :: val_exp
+      REAL, INTENT(in), optional :: masque_lu(iml,jml) 
+      LOGICAL interbar
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. 
+     .MINVAL(champ(:,:)).EQ.val_exp ) THEN
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('relief')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(relief)) THEN
+                      !
+                    if (present(masque_lu)) then
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar, masque_lu )
+                    else
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar)
+                    endif
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(relief) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 'STARTVAR module has been',
+     .' initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = relief(:,:)
+                  !
+              CASE ('rugosite')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(rugo)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(rugo) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = rugo(:,:)
+                  !
+              CASE ('masque')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(masque)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                     jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(masque) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .   'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = masque(:,:)
+                  !
+              CASE ('surfgeo')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = phis(:,:)
+                  !
+              CASE ('psol')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                      !
+                      CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = psol_dyn(:,:)
+                  !
+              CASE DEFAULT
+                  !
+                  WRITE(*,*) 'startget_phys2d'
+                  WRITE(*,*) 'No rule is present to extract variable', 
+     .                 varname(:LEN_TRIM(varname)),' from any data set'
+                  STOP
+                  !
+          END SELECT
+          !
+      ELSE
+          !
+          ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we
+          ! will catch them
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('surfgeo')
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      ALLOCATE(phis(iml,jml))
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  phis(:,:) = champ(:,:)
+                  !
+          END SELECT
+          !
+      ENDIF
+    !
+      END SUBROUTINE startget_phys2d
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 ,
+     ,   lat_in2 , interbar, masque_lu )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, intent(in), optional :: masque_lu(iml,jml)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      LOGICAL interbar2
+      REAL :: lev(1), date, dt,chmin,chmax
+      INTEGER :: itau(1), fid
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+      INTEGER :: iret
+      CHARACTER*25 title
+      REAL, ALLOCATABLE :: relief_hi(:,:)
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: tmp_var(:,:)
+      INTEGER, ALLOCATABLE :: tmp_int(:,:)
+    !
+      CHARACTER*120 :: orogfname
+      LOGICAL :: check=.TRUE.
+    !
+    !
+      orogfname = 'Relief.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Reading the high resolution orography'
+    !
+      CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)
+    !
+      ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret)
+    !
+      CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, 
+     .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp,
+     .      itau, date, dt, fid)
+    !
+      CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, 
+     . ttm_tmp, 1, 1, relief_hi)
+    !
+      CALL flinclo(fid)
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_rel))
+      ALLOCATE(lon_ini(iml_rel))
+
+      IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_rel(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_rel))
+      ALLOCATE(lat_ini(jml_rel))
+
+      IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_rel(1,:) 
+      ENDIF
+    !
+    !
+
+      title='RELIEF'
+
+      interbar2 = .FALSE.
+      CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini,
+     . lon_rad, lat_rad, relief_hi , interbar2  )
+
+      IF ( check ) WRITE(*,*) 'Computes all the parameters needed',
+     .' for the gravity wave drag code'
+    !
+    !    Allocate the data we need to put in the interpolated fields
+    !
+    !            RELIEF:  orographie moyenne
+      ALLOCATE(relief(iml,jml))
+    !            zphi :  orographie moyenne
+      ALLOCATE(phis(iml,jml))
+    !             zstd:  deviation standard de l'orographie sous-maille
+      ALLOCATE(zstd(iml,jml))
+    !             zsig:  pente de l'orographie sous-maille 
+      ALLOCATE(zsig(iml,jml))
+    !             zgam:  anisotropy de l'orographie sous maille
+      ALLOCATE(zgam(iml,jml))
+    !             zthe:  orientation de l'axe oriente dans la direction
+    !                    de plus grande pente de l'orographie sous maille
+      ALLOCATE(zthe(iml,jml))
+    !             zpic:  hauteur pics de la SSO
+      ALLOCATE(zpic(iml,jml))
+    !             zval:  hauteur vallees de la SSO
+      ALLOCATE(zval(iml,jml))
+    !             masque : Masque terre ocean
+      ALLOCATE(tmp_int(iml,jml))
+      ALLOCATE(masque(iml,jml))
+
+      masque = -99999.
+      if (present(masque_lu)) then
+        masque = masque_lu
+      endif
+    !
+      CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, 
+     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque)
+      phis = phis * 9.81
+    !
+!      masque(:,:) = FLOAT(tmp_int(:,:))
+    !
+    !  Compute surface roughness
+    !
+      IF ( check ) WRITE(*,*) 
+     .'Compute surface roughness induced by the orography'
+    !
+      ALLOCATE(rugo(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, tmp_var)
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          rugo(i,j) = tmp_var(i,j)
+        ENDDO
+        rugo(iml,j) = tmp_var(1,j)
+      ENDDO
+c
+cc   ***   rugo  n'est pas utilise pour l'instant  ******
+    !
+    !   Build land-sea mask
+    !
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_orog
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, 
+     .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar)
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, nbindex, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(nbindex)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. 
+     .MINVAL(champ(:)).EQ.val_exp ) THEN
+          SELECTCASE(varname)
+            CASE ('tsol')
+              IF ( .NOT.ALLOCATED(tsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2, lat_in2, interbar )
+              ENDIF
+              IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ)
+            CASE ('qsol')
+              IF ( .NOT.ALLOCATED(qsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ)
+            CASE ('psol')
+              IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ)
+            CASE ('zmea')
+              IF ( .NOT.ALLOCATED(relief)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ)
+            CASE ('zstd')
+              IF ( .NOT.ALLOCATED(zstd)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ)
+            CASE ('zsig')
+              IF ( .NOT.ALLOCATED(zsig)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .               jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ)
+            CASE ('zgam')
+              IF ( .NOT.ALLOCATED(zgam)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ)
+            CASE ('zthe')
+              IF ( .NOT.ALLOCATED(zthe)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ)
+            CASE ('zpic')
+              IF ( .NOT.ALLOCATED(zpic)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ)
+            CASE ('zval')
+              IF ( .NOT.ALLOCATED(zval)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ)
+            CASE ('rads')
+                  champ(:) = 0.0
+            CASE ('snow')
+                  champ(:) = 0.0
+            CASE ('deltat')
+                  champ(:) = 0.0
+            CASE ('rugmer')
+                  champ(:) = 0.001
+            CASE ('agsno')
+                  champ(:) = 50.0
+            CASE DEFAULT
+              WRITE(*,*) 'startget_phys1d'
+              WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+              STOP
+          END SELECT
+      ELSE
+        !
+        ! If we see tsol we catch it as we may need it for a 3D interpolation
+        !
+        SELECTCASE(varname)
+          CASE ('tsol')
+            IF ( .NOT.ALLOCATED(tsol)) THEN
+              ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) ))
+            ENDIF
+            CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol)
+        END SELECT
+      ENDIF
+      END SUBROUTINE startget_phys1d
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2,
+     .                 lon_in2, lat_in2 , interbar )
+    !
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+!ac     REAL :: lev(1), date, dt
+      REAL :: date, dt
+      REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini
+!ac
+      INTEGER :: itau(1)
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+    !
+      CHARACTER*25 title
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:)
+    !
+      physfname = 'ECPHY.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp,
+     . ttm_tmp, fid_phys)
+    !
+      ALLOCATE (lat_phys(iml_phys,jml_phys))
+      ALLOCATE (lon_phys(iml_phys,jml_phys))
+!ac
+      ALLOCATE (levphys_ini(llm_tmp))
+    !
+!      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+!     . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, 
+!     . itau, date, dt, fid_phys)
+    !
+      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+     . llm_tmp, lon_phys, lat_phys, levphys_ini, ttm_tmp, 
+     . itau, date, dt, fid_phys)
+    !
+      DEALLOCATE (levphys_ini)
+!ac
+    !
+    ! Allocate the space we will need to get the data out of this file
+    !
+      ALLOCATE(var_ana(iml_phys, jml_phys))
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_phys))
+      ALLOCATE(lon_ini(iml_phys))
+
+      IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_phys(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_phys))
+      ALLOCATE(lat_ini(jml_phys))
+
+      IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_phys(1,:) 
+      ENDIF
+
+
+    !
+    !   We get the two standard varibales
+    !   Surface temperature
+    !
+      ALLOCATE(tsol(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+    !
+
+      CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, 
+     .llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='ST'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana , interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  ST $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad ,
+     ,   var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var   ) 
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, tsol, iml-1, jml)
+    !
+    ! Soil moisture
+    !
+      ALLOCATE(qsol(iml,jml))
+      CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys,
+     . llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='CDSW'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  CDSW $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad ,
+     ,   var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var  )
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+c
+        CALL gr_int_dyn(tmp_var, qsol, iml-1, jml)
+    !
+       CALL flinclo(fid_phys)
+    !
+      END SUBROUTINE start_init_phys
+    !
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+    !
+      SUBROUTINE startget_dyn(varname, iml, jml, lon_in, lat_in,
+     . lml, pls, workvar, champ, val_exp,jml2, lon_in2, lat_in2 ,
+     ,  interbar )
+    !
+    !   ARGUMENTS
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, lml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(in) :: pls(iml, jml, lml)
+      REAL, INTENT(in) :: workvar(iml, jml, lml)
+      REAL, INTENT(inout) :: champ(iml, jml, lml)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !    LOCAL
+    !
+      INTEGER :: il, ij, ii
+      REAL :: xppn, xpps
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND.
+     . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN
+        !
+        SELECTCASE(varname)
+          CASE ('u')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .          lon_in2,lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('U', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ,interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('v')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, 
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('V', iml, jml, lml, lon_in, 
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('t')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 ,interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+ 
+          CASE ('tpot')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 ,
+     .            lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) )
+     .                                    THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = champ(ii,ij,il) * cpp 
+     .                                 / workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute potential temperature as the'
+              WRITE(*,*)'Exner function is missing or constant.'
+              STOP
+            ENDIF
+          CASE ('q')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in,
+     .        jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) 
+     .                                     THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = 0.01 * champ(ii,ij,il) *
+     .                                       workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              WHERE ( champ .LT. 0.) champ = 1.0E-10
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute specific humidity as the'
+              WRITE(*,*)'saturated humidity is missing or constant.'
+              STOP
+            ENDIF
+          CASE DEFAULT
+            WRITE(*,*) 'startget_dyn'
+            WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+            STOP
+          END SELECT
+      ENDIF
+      END SUBROUTINE startget_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 ,
+     ,             lat_in2 , interbar )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1)
+      INTEGER :: i, j
+      integer :: iret
+    !
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:)
+      REAL, ALLOCATABLE :: xppn(:), xpps(:)
+      LOGICAL :: allo
+    !
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+      CHARACTER*25 title
+
+    !
+      physfname = 'ECDYN.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn,
+     .                            ttm_dyn, fid_dyn)
+      IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, 
+     .                                         llm_dyn, ttm_dyn
+    !
+      ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (levdyn_ini(llm_dyn), stat=iret)
+    !
+      CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn,
+     . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, 
+     . itau, date, dt, fid_dyn)
+    !
+
+      allo = allocated (var_ana)
+      if (allo) then
+        DEALLOCATE(var_ana, stat=iret)
+      endif
+      ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret)
+
+      allo = allocated (lon_rad)
+      if (allo) then
+        DEALLOCATE(lon_rad, stat=iret)
+      endif
+
+      ALLOCATE(lon_rad(iml_dyn), stat=iret)
+      ALLOCATE(lon_ini(iml_dyn))
+       
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+
+      ALLOCATE(z(iml, jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+c
+      title='Z'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+c
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  Z  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad ,
+     ,    var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .               iml-1, jml, lon_in, lat_in, tmp_var)
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, z, iml-1, jml)
+    !
+      ALLOCATE(psol_dyn(iml, jml))
+    !
+      CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+
+       title='SP'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  SP  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad ,
+     ,    var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .             iml-1, jml, lon_in, lat_in, tmp_var  )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml)
+    !
+      IF ( .NOT.ALLOCATED(tsol)) THEN
+    !   These variables may have been allocated by the need to 
+    !   create a start field for them or by the varibale
+    !   coming out of the restart file. In case we dor have it we will initialize it.
+    !
+        CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2,
+     .                 lat_in2 , interbar )
+      ELSE
+        IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN
+        WRITE(*,*) 'start_init_dyn :'
+        WRITE(*,*) 'The temperature field we have does not ',
+     .             'have the right size'
+        STOP
+      ENDIF
+      ENDIF
+      IF ( .NOT.ALLOCATED(phis)) THEN
+            !
+            !    These variables may have been allocated by the need to create a start field for them or by the varibale
+            !     coming out of the restart file. In case we dor have it we will initialize it.
+            !
+        CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 ,
+     .      lat_in2 , interbar )
+            !
+      ELSE
+            !
+          IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN
+                !
+              WRITE(*,*) 'start_init_dyn :'
+              WRITE(*,*) 'The orography field we have does not ',
+     .                   ' have the right size'
+              STOP
+          ENDIF
+            !
+      ENDIF
+    !
+    !     PSOL is computed in Pascals
+    !
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) 
+     .                    /287.0/tsol(i,j))
+        ENDDO
+        psol_dyn(iml,j) = psol_dyn(1,j)
+      ENDDO
+    !
+    !
+      ALLOCATE(xppn(iml-1))
+      ALLOCATE(xpps(iml-1)) 
+    !
+      DO  i   = 1, iml-1
+        xppn(i) = aire( i,1) * psol_dyn( i,1)
+        xpps(i) = aire( i,jml) * psol_dyn( i,jml)
+      ENDDO
+    !
+      DO i   = 1, iml
+        psol_dyn(i,1    )  = SUM(xppn)/apoln
+        psol_dyn(i,jml)  = SUM(xpps)/apols
+      ENDDO
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in,
+     .      lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar )
+    !
+    !    This subroutine gets a variables from a 3D file and does the interpolations needed
+    !
+    !
+    !    ARGUMENTS
+    !
+      CHARACTER*(*) :: varname
+      INTEGER :: iml, jml, lml, jml2
+      REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml)
+      REAL :: lon_in2(iml) , lat_in2(jml2)
+      REAL :: var3d(iml, jml, lml)
+      LOGICAL interbar
+      real chmin,chmax
+    !
+    !  LOCAL
+    !
+      CHARACTER*25 title
+      INTEGER :: ii, ij, il, jsort,i,j,l
+      REAL :: bx, by
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:)
+      REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:)
+      REAL, ALLOCATABLE :: ax(:), ay(:), yder(:)
+       REAL, ALLOCATABLE :: varrr(:,:,:)
+      INTEGER, ALLOCATABLE :: lind(:)
+    !
+      LOGICAL :: check = .TRUE.
+    !
+      IF ( .NOT. ALLOCATED(var_ana3d)) THEN
+          ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn))
+      ENDIF
+          ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn))
+    !
+    !
+      IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ',
+     .  ' field.', fid_dyn
+      IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn,
+     .                        llm_dyn,ttm_dyn
+    !
+      CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, 
+     . ttm_dyn, 1, 1, var_ana3d)
+    !
+      IF ( check) WRITE(*,*) 'Allocating space for the interpolation',
+     . iml, jml, llm_dyn
+    !
+      ALLOCATE(lon_rad(iml_dyn))
+      ALLOCATE(lon_ini(iml_dyn))
+
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      ALLOCATE(lev_dyn(llm_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+      CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, 
+     . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d  ,
+     ,  interbar                                                   )
+
+      ALLOCATE(var_tmp2d(iml-1, jml))
+      ALLOCATE(var_tmp3d(iml, jml, llm_dyn))
+      ALLOCATE(ax(llm_dyn))
+      ALLOCATE(ay(llm_dyn))
+      ALLOCATE(yder(llm_dyn))
+      ALLOCATE(lind(llm_dyn))
+    !
+ 
+      DO il=1,llm_dyn
+        !
+      IF( interbar )  THEN
+       IF( il.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour ', varname
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+       ENDIF
+       CALL inter_barxy ( iml_dyn, jml_dyn -1,lon_rad, lat_rad, 
+     , var_ana3d(:,:,il),iml-1, jml2, lon_in2, lat_in2,jml,var_tmp2d ) 
+      ELSE
+       CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, 
+     .  var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d )
+      ENDIF
+        !
+        CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml)
+        !
+       ENDDO
+       !
+          DO il=1,llm_dyn
+            lind(il) = llm_dyn-il+1
+          ENDDO
+    !
+c
+c  ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere
+c                    vers  le  sol  ...
+c
+      DO ij=1,jml
+        DO ii=1,iml-1
+          !
+          ax(:) = lev_dyn(lind(:)) 
+          ay(:) = var_tmp3d(ii, ij, lind(:))
+          !
+         
+          CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder)
+          !
+          DO il=1,lml
+            bx = pls_in(ii, ij, il)
+            CALL SPLINT(ax, ay, yder, llm_dyn, bx, by)
+            var3d(ii, ij, il) = by
+          ENDDO
+          !
+        ENDDO
+        var3d(iml, ij, :) = var3d(1, ij, :) 
+      ENDDO
+
+      do il=1,lml
+        call minmax(iml*jml,var3d(1,1,il),chmin,chmax)
+      SELECTCASE(varname)
+       CASE('U')
+          WRITE(*,*) ' U  min max l ',il,chmin,chmax
+       CASE('V')
+          WRITE(*,*) ' V  min max l ',il,chmin,chmax
+       CASE('TEMP')
+          WRITE(*,*) ' TEMP  min max l ',il,chmin,chmax
+       CASE('R')
+          WRITE(*,*) ' R  min max l ',il,chmin,chmax
+      END SELECT
+           enddo
+
+      DEALLOCATE(lon_rad)
+      DEALLOCATE(lat_rad)
+      DEALLOCATE(var_tmp2d)
+      DEALLOCATE(var_tmp3d)
+      DEALLOCATE(ax)
+      DEALLOCATE(ay)
+      DEALLOCATE(yder)
+      DEALLOCATE(lind)
+
+    !
+      RETURN
+    !
+      END SUBROUTINE start_inter_3d
+    !
+      END MODULE startvar
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/temps.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/temps.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/temps.h	(revision 984)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref,   &
+     &             itau_dyn, itau_phy
+
+      INTEGER   itaufin
+      INTEGER*4 itau_dyn, itau_phy
+      INTEGER*4 day_ini, day_end, annee_ref, day_ref
+      REAL      dt
+
+!-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/test_period.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/test_period.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/test_period.F	(revision 984)
@@ -0,0 +1,114 @@
+!
+! $Header$
+!
+      SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
+c
+c     Auteur : P. Le Van  
+c    ---------
+c  ....  Cette routine teste la periodicite en longitude des champs   ucov,
+c                           teta, q , p et phis                 .......... 
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+c    ......  Arguments   ......
+c
+      REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) ,
+     ,      q(ip1jmp1,llm,nqmx), p(ip1jmp1,llmp1), phis(ip1jmp1)
+c
+c   .....  Variables  locales  .....
+c
+      INTEGER ij,l,nq
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( ucov(ij,l).NE.ucov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  UCOV  ---  n est pas',  
+     ,  ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( teta(ij,l).NE.teta(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,   ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+     ,      , teta(ij,l),   teta(ij+iim,l)
+          STOP
+          ENDIF
+         ENDDO
+
+         do ij=1,iim
+          if (teta(ij,l).ne.teta(1,l)
+     s     .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,  ' constant aux poles ! '
+          print*,'teta(',1 ,',',l,')=',teta(1 ,l)
+          print*,'teta(',ij,',',l,')=',teta(ij,l)
+          print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l)
+          print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l)
+          stop
+          endif
+         enddo
+      ENDDO
+
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jm, iip1
+          IF( vcov(ij,l).NE.vcov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  VCOV  ---  n est pas',  
+     ,   ' periodique en longitude !'
+          PRINT *,' l,  ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l)
+          vcov(ij+iim,l)=vcov(ij,l)
+c         STOP
+          ENDIF
+         ENDDO
+      ENDDO
+      
+c
+      DO nq =1, nqmx
+        DO l =1, llm
+          DO ij = 1, ip1jmp1, iip1
+          IF( q(ij,l,nq).NE.q(ij+iim,l,nq) )  THEN
+          PRINT *,'STOP dans test_period car ---  Q  ---  n est pas ',  
+     ,   'periodique en longitude !'
+          PRINT *,' nq , l,  ij = ', nq, l, ij, ij+iim
+          STOP
+          ENDIF
+          ENDDO
+        ENDDO
+      ENDDO
+c
+       DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( p(ij,l).NE.p(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  P  ---  n est pas',  
+     ,    ' periodique en longitude !'
+          PRINT *,' l ij = ',l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( phis(ij).NE.phis(ij+iim) )  THEN
+          PRINT *,'STOP dans test_period car ---  PHIS  ---  n est pas',  
+     ,   ' periodique en longitude !  l, IJ = ', l, ij,ij+iim
+          PRINT *,' ij = ', ij, ij+iim
+          STOP
+          ENDIF
+         ENDDO
+         do ij=1,iim
+          if (p(ij,l).ne.p(1,l)
+     s     .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then
+          PRINT *,'STOP dans test_period car ---  P     ---  n est pas',  
+     ,  ' constant aux poles ! '
+          print*,'p(',1 ,',',l,')=',p(1 ,l)
+          print*,'p(',ij,',',l,')=',p(ij,l)
+          print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l)
+          print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l)
+          stop
+          endif
+         enddo
+       ENDDO
+c
+c
+         RETURN
+         END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/times.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/times.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/times.F90	(revision 984)
@@ -0,0 +1,230 @@
+module times
+  integer,private,save :: Last_Count=0
+  real, private,save :: Last_cpuCount=0
+  logical, private,save :: AllTimer_IsActive=.false.
+  
+  integer, parameter :: nb_timer = 4
+  integer, parameter :: timer_caldyn  = 1
+  integer, parameter :: timer_vanleer = 2
+  integer, parameter :: timer_dissip = 3
+  integer, parameter :: timer_physic = 4
+  integer, parameter :: stopped = 1
+  integer, parameter :: running = 2
+  integer, parameter :: suspended = 3 
+  
+  integer :: max_size
+  real,    allocatable, dimension(:,:,:) :: timer_table
+  real,    allocatable, dimension(:,:,:) :: timer_table_sqr 
+  integer, allocatable, dimension(:,:,:) :: timer_iteration
+  real,    allocatable, dimension(:,:,:) :: timer_average
+  real,    allocatable, dimension(:,:,:) :: timer_delta
+  real,    allocatable,dimension(:) :: timer_running, last_time
+  integer, allocatable,dimension(:) :: timer_state
+  
+  contains
+  
+  subroutine init_timer
+    use parallel
+    implicit none
+#include "dimensions.h"
+#include "paramet.h"
+    
+    max_size=jjm+1
+    allocate(timer_table(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_average(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_delta(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_running(nb_timer))
+    allocate(timer_state(nb_timer))
+    allocate(last_time(nb_timer))
+    
+    timer_table(:,:,:)=0
+    timer_table_sqr(:,:,:)=0
+    timer_iteration(:,:,:)=0
+    timer_average(:,:,:)=0
+    timer_delta(:,:,:)=0
+    timer_state(:)=stopped      
+  end subroutine init_timer
+  
+  subroutine start_timer(no_timer)
+    implicit none
+    integer :: no_timer
+    
+    if (AllTimer_IsActive) then
+    
+      if (timer_state(no_timer)/=stopped) then
+        stop 'start_timer :: timer is already running or suspended'
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      timer_running(no_timer)=0
+      call cpu_time(last_time(no_timer))
+    
+    endif
+    
+  end subroutine start_timer
+  
+  subroutine suspend_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=running) then
+        stop 'suspend_timer :: timer is not running'
+      else
+        timer_state(no_timer)=suspended
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    endif
+  end subroutine suspend_timer
+  
+  subroutine resume_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=suspended) then
+        stop 'resume_timer :: timer is not suspended'
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      call cpu_time(last_time(no_timer))
+    endif
+    
+  end subroutine resume_timer
+
+  subroutine stop_timer(no_timer)
+    use parallel
+    implicit none
+    integer :: no_timer
+    integer :: N
+    real :: V,V2
+    
+    if (AllTimer_IsActive) then
+       
+      if (timer_state(no_timer)/=running) then
+        stop 'stop_timer :: timer is not running'
+      else
+        timer_state(no_timer)=stopped
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    
+      timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)
+      timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2
+      timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1
+      timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank)
+      if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then
+        N=timer_iteration(jj_nb,no_timer,mpi_rank)
+	V2=timer_table_sqr(jj_nb,no_timer,mpi_rank)
+	V=timer_table(jj_nb,no_timer,mpi_rank)
+	timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) 
+      else
+        timer_delta(jj_nb,no_timer,mpi_rank)=0
+      endif
+    endif
+    
+  end subroutine stop_timer
+   
+  subroutine allgather_timer
+    use parallel
+    implicit none
+    include 'mpif.h'
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:) :: tmp_table
+    
+    if (AllTimer_IsActive) then
+    
+    allocate(tmp_table(max_size,nb_timer))
+    
+    data_size=max_size*nb_timer
+    
+    tmp_table(:,:)=timer_table(:,:,mpi_rank)
+    call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL8,timer_table(1,1,mpi_rank),data_size,MPI_REAL8,COMM_LMDZ,ierr)
+
+    tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank)
+    call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL8,timer_table_sqr(1,1,mpi_rank),data_size,MPI_REAL8,COMM_LMDZ,ierr)
+    
+    deallocate(tmp_table)
+    
+    endif
+    
+  end subroutine allgather_timer
+  
+  subroutine allgather_timer_average
+    use parallel
+    implicit none
+    include 'mpif.h'
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:),target :: tmp_table
+    integer, allocatable,dimension(:,:),target :: tmp_iter
+    integer :: istats
+    
+    if (AllTimer_IsActive) then
+    
+    allocate(tmp_table(max_size,nb_timer))
+    allocate(tmp_iter(max_size,nb_timer))
+   
+    data_size=max_size*nb_timer
+
+    tmp_table(:,:)=timer_average(:,:,mpi_rank)
+    call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL8,timer_average(1,1,0),data_size,MPI_REAL8,COMM_LMDZ,ierr)
+
+    tmp_table(:,:)=timer_delta(:,:,mpi_rank)
+    call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL8,timer_delta(1,1,0),data_size,MPI_REAL8,COMM_LMDZ,ierr)
+
+    tmp_iter(:,:)=timer_iteration(:,:,mpi_rank)
+    call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr)
+    
+    deallocate(tmp_table)
+    
+    endif
+  end subroutine allgather_timer_average
+  
+  subroutine InitTime
+  implicit none
+    integer :: count,count_rate,count_max
+    
+    AllTimer_IsActive=.TRUE.
+    if (AllTimer_IsActive) then
+      call system_clock(count,count_rate,count_max)
+      call cpu_time(Last_cpuCount)
+      Last_Count=count
+    endif
+  end subroutine InitTime
+  
+  function DiffTime
+  implicit none
+    double precision :: DiffTime
+    integer :: count,count_rate,count_max
+  
+    call system_clock(count,count_rate,count_max)
+    if (Count>=Last_Count) then
+      DiffTime=(1.*(Count-last_Count))/count_rate
+    else
+      DiffTime=(1.*(Count-last_Count+Count_max))/count_rate
+    endif
+    Last_Count=Count 
+  end function DiffTime
+  
+  function DiffCpuTime
+  implicit none
+    real :: DiffCpuTime
+    real :: Count
+    
+    call cpu_time(Count)
+    DiffCpuTime=Count-Last_cpuCount
+    Last_cpuCount=Count 
+  end function DiffCpuTime
+
+end module times
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/tourabs.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/tourabs.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/tourabs.F	(revision 984)
@@ -0,0 +1,98 @@
+      SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Modif:  I. Musat (28/10/04)
+c   -------
+c   adaptation du code tourpot.F pour le calcul de la vorticite absolue
+c   cf. P. Le Van
+c
+c   Objet: 
+c   ------
+c
+c    *******************************************************************
+c    .............  calcul de la vorticite absolue     .................
+c    *******************************************************************
+c
+c     ntetaSTD, vcov,ucov      sont des argum. d'entree pour le s-pg .
+c             vorabs            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "comconst.h"
+c
+      INTEGER ntetaSTD
+      REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD )
+      REAL vorabs( ip1jm,ntetaSTD )
+c
+c variables locales
+      INTEGER l, ij, i, j
+      REAL  rot( ip1jm,ntetaSTD )
+
+
+
+c  ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,ntetaSTD
+
+      DO 2 i = 1, iip1
+      DO 2 j = 1, jjm
+c
+       ij=i+(j-1)*iip1
+       IF(ij.LE.ip1jm - 1) THEN
+c
+        IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR.
+     $     cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN
+         rot( ij,l ) = 0.
+         continue
+        ELSE
+         rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/
+     $                 (2.*pi*RAD*cos(rlatv(j)))*float(iim)
+     $                +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/
+     $                 (pi*RAD)*(float(jjm)-1.)
+c
+        ENDIF
+       ENDIF !(ij.LE.ip1jm - 1) THEN
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, ntetaSTD
+
+      DO 6 ij = 1, ip1jm - 1
+      vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) )
+   6  CONTINUE
+
+c    ..... correction pour  vorabs( iip1,j,l)  .....
+c    ....   vorabs(iip1,j,l)= vorabs(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorabs( ij,l ) = vorabs( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/tourpot_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/tourpot_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/tourpot_p.F	(revision 984)
@@ -0,0 +1,93 @@
+      SUBROUTINE tourpot_p ( vcov, ucov, massebxy, vorpot )
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ip1jm,llm )
+      REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm )
+      REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm )
+
+      INTEGER l, ij ,ije,ijb,jje,jjb
+
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      
+      if (pole_nord) ijb=ij_begin
+      
+      
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO 5 l = 1,llm
+
+      if (pole_sud)  ije=ij_end-iip1-1
+      DO 2 ij = ijb, ije 
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      if (pole_sud)  ije=ij_end-iip1
+     
+      DO 3 ij = ijb+iip1-1, ije, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+c$OMP END DO NOWAIT
+      jjb=jj_begin-1
+      jje=jj_end
+      
+      if (pole_nord) jjb=jjb+1
+      if (pole_sud)  jje=jje-1
+      CALL  filtreg_p( rot, jjb,jje,jjm, llm, 2, 1, .FALSE., 1 )
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
+      DO 10 l = 1, llm
+      
+      if (pole_sud)  ije=ij_end-iip1-1  
+      
+      DO 6 ij = ijb, ije
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      if (pole_sud)  ije=ij_end-iip1
+      DO 8 ij = ijb+iip1-1, ije, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/traceurpole.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/traceurpole.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/traceurpole.F	(revision 984)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+          subroutine traceurpole(q,masse)
+
+          implicit none
+      
+#include "dimensions.h"
+c#include "paramr2.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+
+c   Arguments
+       integer iq
+       real masse(iip1,jjp1,llm)
+       real q(iip1,jjp1,llm)
+       
+
+c   Locals
+      integer i,j,l
+      real sommemassen(llm)
+      real sommemqn(llm)
+      real sommemasses(llm)
+      real sommemqs(llm)
+      real qpolen(llm),qpoles(llm)
+
+    
+c On impose une seule valeur au pôle Sud j=jjm+1=jjp1       
+      sommemasses=0
+      sommemqs=0
+          do l=1,llm
+             do i=1,iip1          
+                 sommemasses(l)=sommemasses(l)+masse(i,jjp1,l)
+                 sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l)
+             enddo         
+          qpoles(l)=sommemqs(l)/sommemasses(l)
+          enddo
+
+c On impose une seule valeur du traceur au pôle Nord j=1
+      sommemassen=0
+      sommemqn=0  
+         do l=1,llm
+           do i=1,iip1              
+               sommemassen(l)=sommemassen(l)+masse(i,1,l)
+               sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l)
+           enddo
+           qpolen(l)=sommemqn(l)/sommemassen(l) 
+         enddo
+    
+c On force le traceur à prendre cette valeur aux pôles
+        do l=1,llm
+            do i=1,iip1
+               q(i,1,l)=qpolen(l)
+               q(i,jjp1,l)=qpoles(l)
+             enddo
+        enddo
+
+      
+      return
+      end           
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/tracstoke.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/tracstoke.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/tracstoke.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/ugeostr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/ugeostr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/ugeostr.F	(revision 984)
@@ -0,0 +1,67 @@
+!
+! $Header$
+!
+      subroutine ugeostr(phi,ucov)
+
+
+c  Calcul du vent covariant geostrophique a partir du champs de
+c  geopotentiel en supposant que le vent au sol est nul.
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+      real um(jjm,llm),fact,u(iip1,jjm,llm)
+      integer i,j,l
+
+      real zlat
+
+      DO j=1,jjm
+
+         if (abs(sin(rlatv(j))).lt.1.e-4) then
+             zlat=1.e-4
+         else
+             zlat=rlatv(j)
+         endif
+         fact=cos(zlat)
+         fact=fact*fact
+         fact=fact*fact
+         fact=fact*fact
+         fact=(1.-fact)/
+     s    (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j)))
+         fact=-fact/rad
+         DO l=1,llm
+            DO i=1,iim
+               u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
+               um(j,l)=um(j,l)+u(i,j,l)/float(iim)
+            ENDDO
+         ENDDO
+      ENDDO
+      call dump2d(jjp1,llm,um,'Vent-u geostrophique')
+
+c
+c-----------------------------------------------------------------------
+c   calcul des champ de vent:
+c   -------------------------
+
+      DO 301 l=1,llm
+         DO 302 i=1,iip1
+            ucov(i,1,l)=0.
+            ucov(i,jjp1,l)=0.
+302      CONTINUE
+         DO 304 j=2,jjm
+            DO 305 i=1,iim
+               ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j)
+305         CONTINUE
+            ucov(iip1,j,l)=ucov(1,j,l)
+304      CONTINUE
+301   CONTINUE
+
+      print*,301
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/vitvert_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/vitvert_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/vitvert_p.F	(revision 984)
@@ -0,0 +1,56 @@
+      SUBROUTINE vitvert_p ( convm , w )
+c
+      USE parallel
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ip1jmp1,llm),convm(ip1jmp1,llm)
+      INTEGER   l, ij,ijb,ije
+
+
+      ijb=ij_begin
+      ije=ij_end+iip1
+      
+      if (pole_sud) ije=ij_end
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = ijb,ije
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+c$OMP END DO
+c$OMP MASTER
+      DO 5 ij  = ijb,ije
+      w(ij,1)  = 0.
+5     CONTINUE
+c$OMP END MASTER
+c$OMP BARRIER
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlsplt_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlsplt_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlsplt_p.F	(revision 984)
@@ -0,0 +1,1138 @@
+      SUBROUTINE vlsplt_p(q,pente_max,masse,w,pbaru,pbarv,pdt)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pente_max facteur de limitation des pentes: 2 en general
+c                                               0 pour un schema amont
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      USE parallel
+      USE mod_hallo
+      USE Vampir
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+c      REAL masse(iip1,jjp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+c      REAL q(iip1,jjp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      INTEGER ijlqmin,iqmin,jqmin,lqmin
+c
+      REAL zm(ip1jmp1,llm),newmasse
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm),zz
+      REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
+      REAL second,temps0,temps1,temps2,temps3
+      REAL ztemps1,ztemps2,ztemps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+      INTEGER iminn,imaxx
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+      INTEGER ijb,ije
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+      call SetTag(MyRequest1,100)
+      call SetTag(MyRequest2,101)
+      
+      zzpbar = 0.5 * pdt
+      zzw    = pdt
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+      
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+        ENDDO
+      ENDDO
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO l=1,llm
+        DO ij=ijb,ije
+           mv(ij,l)=pbarv(ij,l) * zzpbar
+        ENDDO
+      ENDDO
+      
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,llm
+        DO ij=ijb,ije
+           mw(ij,l)=w(ij,l) * zzw
+        ENDDO
+      ENDDO
+
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+      
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+       
+       ijb=ij_begin
+       ije=ij_end
+       zq(ijb:ije,:)=q(ijb:ije,:)
+       zm(ijb:ije,:)=masse(ijb:ije,:)
+      
+      
+c	print*,'Entree vlx1'
+c	call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_begin+2*iip1-1)
+      call vlx_p(zq,pente_max,zm,mu,ij_end-2*iip1+1,ij_end)
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1)
+      call SendRequest(MyRequest1)
+      call VTe(VTHallo)
+      call vlx_p(zq,pente_max,zm,mu,ij_begin+2*iip1,ij_end-2*iip1)
+c      call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end)
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest1)
+      call VTe(VTHallo)
+
+      
+c	print*,'Sortie vlx1'
+c	call minmaxq(zq,qmin,qmax,'apres vlx1    ')
+
+c	 print*,'Entree vly1'
+c      call exchange_hallo(zq,ip1jmp1,llm,2,2)
+c      call exchange_hallo(zm,ip1jmp1,llm,1,1)
+      
+      call vly_p(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly1     ')
+c	print*,'Sortie vly1'
+      call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1)
+      call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end)
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2)
+      call SendRequest(MyRequest2)
+      call VTe(VTHallo)
+      call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1)
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest2)
+            
+      call VTe(VTHallo)
+      
+c	call minmaxq(zq,qmin,qmax,'apres vlz     ')
+
+
+      
+      
+      call vly_p(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly     ')
+
+
+      call vlx_p(zq,pente_max,zm,mu,ij_begin,ij_end)
+c	call minmaxq(zq,qmin,qmax,'apres vlx2    ')
+
+	
+      ijb=ij_begin
+      ije=ij_end
+       
+      DO l=1,llm
+         DO ij=ijb,ije
+           q(ij,l)=zq(ij,l)
+         ENDDO
+      ENDDO
+      
+      
+      DO l=1,llm
+         DO ij=ijb,ije-iip1+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      call WaitSendRequest(MyRequest1) 
+      call WaitSendRequest(MyRequest2)
+     
+      RETURN
+      END
+      
+      
+      SUBROUTINE vlx_p(q,pente_max,masse,u_m,ijb_x,ije_x)
+
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE Parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical extremum
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      REAL z1,z2,z3
+
+      INTEGER ijb,ije,ijb_x,ije_x
+      
+c   calcul de la pente a droite et a gauche de la maille
+
+      ijb=ijb_x
+      ije=ije_x
+        
+      if (pole_nord.and.ijb==1) ijb=ijb+iip1
+      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+         
+      IF (pente_max.gt.-1.e-5) THEN
+c       IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
+         DO l = 1, llm
+            
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+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)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=ijb,ije
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=ijb+1,ije
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=ijb+1,ije
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+c$OMP END DO NOWAIT
+c	print*,'Ok calcul des pentes'
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=ijb+1,ije
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+iip1-1,ije,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+         DO ij=ijb,ije
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+c$OMP END DO NOWAIT
+c	 print*,'Bouclage en iip1'
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      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)=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),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#else
+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	print*,'Cumule ....'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb,ije-1
+c	print*,'masse(',ij,')=',masse(ij,l)
+          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))
+          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))
+          ENDIF
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+c	stop
+
+c	go to 9999
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c	print*,'Ok test 1'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb+iip1-1,ije,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+c	 print*,'Ok test 2'
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         nl(l)=0
+         DO ij=ijb,ije
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+c$OMP END DO NOWAIT
+cym      IF(n0.gt.1) THEN
+cym      IF(n0.gt.0) THEN
+
+c      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+c     &       ,'contenu de la maille : ',n0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     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)
+                        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))
+                  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)
+                        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))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+c$OMP END DO NOWAIT
+cym      ENDIF  ! n0.gt.0 
+9999    continue
+
+
+c   bouclage en latitude
+c	print*,'Avant bouclage en latitude'
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        DO ij=ijb+iip1-1,ije,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+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
+         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
+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)
+
+
+      RETURN
+      END
+
+
+      SUBROUTINE vly_p(q,pente_max,masse,masse_adv_v)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical extremum,first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+      SAVE first,testcpu
+c$OMP THREADPRIVATE(first,testcpu)
+
+      REAL convpn,convps,convmpn,convmps
+      real massepn,masseps,qpn,qps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+      SAVE airej2,airejjm
+c$OMP THREADPRIVATE(airej2,airejjm)
+c
+c
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+      INTEGER ijb,ije
+
+      IF(first) THEN
+c         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+c	PRINT*,'CALCUL EN LATITUDE'
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+      
+      if (pole_nord) then
+        DO i = 1, iim
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+        ENDDO
+        qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      endif
+      
+      if (pole_sud) then
+        DO i = 1, iim
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+        ENDDO
+        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+      endif
+      
+      
+
+c   calcul des pentes aux points v
+
+      ijb=ij_begin-2*iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+      IF (pole_nord) THEN
+        DO ij=1,iip1
+           dyq(ij,l)=qpns-q(ij+iip1,l)
+        ENDDO
+        
+        dyn1=0.
+        dyn2=0.
+        DO ij=1,iim
+          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+        ENDDO
+        DO ij=1,iip1
+          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+        ENDDO
+        
+        DO ij=1,iip1
+         dyq(ij,l)=0.
+        ENDDO
+c ym tout cela ne sert pas a grand chose
+      ENDIF
+      
+      IF (pole_sud) THEN
+
+        DO ij=1,iip1
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+        ENDDO
+
+        dys1=0.
+        dys2=0.
+
+        DO ij=1,iim
+          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+        ENDDO
+
+        DO ij=1,iip1
+          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+        ENDDO
+        
+        DO ij=1,iip1
+         dyq(ip1jm+ij,l)=0.
+        ENDDO
+c ym tout cela ne sert pas a grand chose
+      ENDIF
+
+c   filtrage de la derivee
+
+c   calcul des pentes limites aux poles
+c ym partie inutile
+c      goto 8888
+c      fn=1.
+c      fs=1.
+c      DO ij=1,iim
+c         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+c            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+c         ENDIF
+c      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+c         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+c         ENDIF
+c      ENDDO
+c      DO ij=1,iip1
+c         dyq(ij,l)=fn*dyq(ij,l)
+c         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+c      ENDDO
+c 8888    continue
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+
+      DO ij=ijb,ije
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       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))
+          ELSE
+              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+          ENDIF
+          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      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
+c.-. ancienne version
+c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+         if (pole_nord) then
+           convpn=SSUM(iim,qbyv(1,l),1)
+           convmpn=ssum(iim,masse_adv_v(1,l),1)
+           massepn=ssum(iim,masse(1,l),1)
+           qpn=0.
+           do ij=1,iim
+              qpn=qpn+masse(ij,l)*q(ij,l)
+           enddo
+           qpn=(qpn+convpn)/(massepn+convmpn)
+           do ij=1,iip1
+              q(ij,l)=qpn
+           enddo
+         endif
+         
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+         
+         if (pole_sud) then
+         
+           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)
+           qps=0.
+           do ij = ip1jm+1,ip1jmp1-1
+              qps=qps+masse(ij,l)*q(ij,l)
+           enddo
+           qps=(qps+convps)/(masseps+convmps)
+           do ij=ip1jm+1,ip1jmp1
+              q(ij,l)=qps
+           enddo
+         endif
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*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        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*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        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+
+      RETURN
+      END
+      
+      
+      
+      SUBROUTINE vlz_p(q,pente_max,masse,w,ijb_x,ije_x)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE Parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL,SAVE :: wq(ip1jmp1,llm+1)
+      REAL newmasse
+
+      REAL,SAVE :: dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm)
+      REAL dzqmax
+      REAL sigw
+
+      LOGICAL testcpu
+      SAVE testcpu
+c$OMP THREADPRIVATE(testcpu)
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5)
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      DATA testcpu/.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+      INTEGER ijb,ije,ijb_x,ije_x
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps0=second(0.)
+      ENDIF
+#endif
+
+      ijb=ijb_x
+      ije=ije_x
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=2,llm
+         DO ij=ijb,ije
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         ENDDO
+      ENDDO
+c$OMP END DO
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=2,llm-1
+         DO ij=ijb,ije
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            ELSE
+                dzq(ij,l)=0.
+            ENDIF
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+      DO ij=ijb,ije
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      ENDDO
+c$OMP END MASTER
+c$OMP BARRIER
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps1=temps1+second(0.)-temps0
+      ENDIF
+#endif
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+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))
+          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))
+          ENDIF
+         ENDDO
+       ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+       DO ij=ijb,ije
+          wq(ij,llm+1)=0.
+          wq(ij,1)=0.
+       ENDDO
+c$OMP END MASTER
+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)=newmasse
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+      RETURN
+      END
+c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
+c
+c#include "dimensions.h"
+c#include "paramet.h"
+
+c      CHARACTER*(*) comment
+c      real qmin,qmax
+c      real zq(ip1jmp1,llm)
+
+c      INTEGER jadrs(ip1jmp1), jbad, k, i
+
+
+c      DO k = 1, llm
+c         jbad = 0
+c         DO i = 1, ip1jmp1
+c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+c            jbad = jbad + 1
+c            jadrs(jbad) = i
+c         ENDIF
+c         ENDDO
+c         IF (jbad.GT.0) THEN
+c         PRINT*, comment
+c         DO i = 1, jbad
+cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
+c         ENDDO
+c         ENDIF
+c      ENDDO
+
+c      return
+c      end
+
+
+      subroutine minmaxq_p(zq,qmin,qmax,comment)
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      character*20 comment
+      real qmin,qmax
+      real zq(ip1jmp1,llm)
+      real zzq(iip1,jjp1,llm)
+
+      integer imin,jmin,lmin,ijlmin
+      integer imax,jmax,lmax,ijlmax
+
+      integer ismin,ismax
+
+#ifdef isminismax
+      call scopy (ip1jmp1*llm,zq,1,zzq,1)
+
+      ijlmin=ismin(ijp1llm,zq,1)
+      lmin=(ijlmin-1)/ip1jmp1+1
+      ijlmin=ijlmin-(lmin-1.)*ip1jmp1
+      jmin=(ijlmin-1)/iip1+1
+      imin=ijlmin-(jmin-1.)*iip1
+      zqmin=zq(ijlmin,lmin)
+
+      ijlmax=ismax(ijp1llm,zq,1)
+      lmax=(ijlmax-1)/ip1jmp1+1
+      ijlmax=ijlmax-(lmax-1.)*ip1jmp1
+      jmax=(ijlmax-1)/iip1+1
+      imax=ijlmax-(jmax-1.)*iip1
+      zqmax=zq(ijlmax,lmax)
+
+       if(zqmin.lt.qmin) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
+       if(zqmax.gt.qmax) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
+#endif
+      return
+9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
+      end
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlspltgen_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlspltgen_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlspltgen_p.F	(revision 984)
@@ -0,0 +1,366 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltgen_p( q,iadv,pente_max,masse,w,pbaru,pbarv,pdt,
+     ,                                  p,pk,teta                 )
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
+c
+c    ********************************************************************
+c          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      USE parallel
+      USE mod_hallo
+      USE Write_Field_p
+      USE VAMPIR
+      IMPLICIT NONE
+
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      INTEGER iadv(nqmx)
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm,nqmx)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      REAL,SAVE :: qsat(ip1jmp1,llm)
+      REAL,SAVE :: zm(ip1jmp1,llm,nqmx)
+      REAL,SAVE :: mu(ip1jmp1,llm)
+      REAL,SAVE :: mv(ip1jm,llm)
+      REAL,SAVE :: mw(ip1jmp1,llm+1)
+      REAL,SAVE :: zq(ip1jmp1,llm,nqmx)
+      REAL zzpbar, zzw
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+      REAL tempe(ip1jmp1)
+      INTEGER ijb,ije,iq
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c-- Calcul de Qsat en chaque point
+c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+c   pour eviter une exponentielle.
+c$OMP MASTER
+      call SetTag(MyRequest1,100)
+      call SetTag(MyRequest2,101)
+c$OMP END MASTER
+        
+	ijb=ij_begin-iip1
+	ije=ij_end+iip1
+	if (pole_nord) ijb=ij_begin
+	if (pole_sud) ije=ij_end
+	
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+	DO l = 1, llm
+         DO ij = ijb, ije
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = ijb, ije
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+c$OMP END DO NOWAIT
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin
+      ije=ij_end
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l=1,llm
+         DO ij=ijb,ije
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP MASTER
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+c$OMP END MASTER
+
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+       ijb=ij_begin
+       ije=ij_end
+
+      DO iq=1,nqmx
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+        DO l=1,llm
+          zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
+          zm(ijb:ije,l,iq)=masse(ijb:ije,l)
+        ENDDO
+c$OMP END DO NOWAIT
+      ENDDO
+
+
+c$OMP BARRIER           
+      DO iq=1,nqmx
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+	  call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &	             ij_begin,ij_end)
+
+c$OMP MASTER
+          call VTb(VTHallo)
+          call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1)
+          call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1)
+          call VTe(VTHallo)
+c$OMP END MASTER
+	else if (iadv(iq)==14) then
+      
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_begin,ij_end)
+c$OMP MASTER
+          call VTb(VTHallo)
+          call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest1)
+          call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest1)
+          call VTe(VTHallo)
+c$OMP END MASTER 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+      
+      enddo
+      
+      
+c$OMP BARRIER      
+c$OMP MASTER      
+      call VTb(VTHallo)
+      call SendRequest(MyRequest1)
+      call WaitRecvRequest(MyRequest1)
+      call WaitSendRequest(MyRequest1)
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+ 
+      do iq=1,nqmx
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+      do iq=1,nqmx
+
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
+
+c$OMP BARRIER        
+          call vlz_p(zq(1,1,iq),pente_max,zm(1,1,iq),mw,
+     &               ij_begin,ij_end)
+c$OMP BARRIER
+
+c$OMP MASTER
+          call VTb(VTHallo)
+          call Register_Hallo(zq(1,1,iq),ip1jmp1,llm,2,2,2,2,MyRequest2)
+          call Register_Hallo(zm(1,1,iq),ip1jmp1,llm,1,1,1,1,MyRequest2)
+          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)
+      call SendRequest(MyRequest2)
+      call WaitRecvRequest(MyRequest2)
+      call WaitSendRequest(MyRequest2)
+      call VTe(VTHallo)
+c$OMP END MASTER
+c$OMP BARRIER
+
+
+      do iq=1,nqmx
+
+        if(iadv(iq) == 0) then
+	
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vly_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlyqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mv,qsat)
+ 
+        else
+	
+	  stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+      do iq=1,nqmx
+
+        if(iadv(iq) == 0) then 
+	  
+	  cycle 
+	
+	else if (iadv(iq)==10) then
+        
+          call vlx_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,
+     &               ij_begin,ij_end)
+  
+	else if (iadv(iq)==14) then
+      
+          call vlxqs_p(zq(1,1,iq),pente_max,zm(1,1,iq),mu,qsat,
+     &                 ij_begin,ij_end)
+ 
+        else
+	
+          stop 'vlspltgen_p : schema non parallelise'
+      
+        endif
+       
+       enddo
+
+     
+      ijb=ij_begin
+      ije=ij_end
+c$OMP BARRIER      
+
+      DO iq=1,nqmx
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)          
+        DO l=1,llm
+           DO ij=ijb,ije
+c             print *,'zq-->',ij,l,iq,zq(ij,l,iq)
+c	     print *,'q-->',ij,l,iq,q(ij,l,iq)
+	     q(ij,l,iq)=zq(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT          
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           DO ij=ijb,ije-iip1+1,iip1
+              q(ij+iim,l,iq)=q(ij,l,iq)
+           ENDDO
+        ENDDO
+c$OMP END DO NOWAIT  
+
+      ENDDO
+        
+      
+c$OMP BARRIER
+
+cc$OMP MASTER      
+c      call WaitSendRequest(MyRequest1) 
+c      call WaitSendRequest(MyRequest2)
+cc$OMP END MASTER
+cc$OMP BARRIER
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlspltqs_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlspltqs_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/vlspltqs_p.F	(revision 984)
@@ -0,0 +1,940 @@
+!
+! $Header$
+!
+       SUBROUTINE vlspltqs_p ( q,pente_max,masse,w,pbaru,pbarv,pdt,
+     ,                                  p,pk,teta                 )
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
+c
+c    ********************************************************************
+c          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      USE parallel
+      USE mod_hallo
+      USE VAMPIR
+      IMPLICIT NONE
+
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL qsat(ip1jmp1,llm)
+      REAL zm(ip1jmp1,llm)
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm)
+      REAL temps1,temps2,temps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+      REAL tempe(ip1jmp1)
+      INTEGER ijb,ije
+      type(request) :: MyRequest1
+      type(request) :: MyRequest2
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c-- Calcul de Qsat en chaque point
+c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+c   pour eviter une exponentielle.
+
+      call SetTag(MyRequest1,100)
+      call SetTag(MyRequest2,101)
+        
+	ijb=ij_begin-iip1
+	ije=ij_end+iip1
+	if (pole_nord) ijb=ij_begin
+	if (pole_sud) ije=ij_end
+	
+	
+	DO l = 1, llm
+         DO ij = ijb, ije
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = ijb, ije
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ijb+iip1
+      if (pole_sud)  ije=ije-iip1
+
+      
+      DO l=1,llm
+        DO ij = ijb,ije
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+      
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+
+      DO l=1,llm
+         DO ij=ijb,ije
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+      ENDDO
+
+      ijb=ij_begin
+      ije=ij_end
+      
+      DO l=1,llm
+         DO ij=ijb,ije
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=ijb,ije
+         mw(ij,llm+1)=0.
+      ENDDO
+
+c      CALL SCOPY(ijp1llm,q,1,zq,1)
+c      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+       ijb=ij_begin
+       ije=ij_end
+       zq(ijb:ije,1:llm)=q(ijb:ije,1:llm)
+       zm(ijb:ije,1:llm)=masse(ijb:ije,1:llm)
+
+
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_begin+2*iip1-1)
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_end-2*iip1+1,ij_end)
+ 
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest1)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest1)
+      call SendRequest(MyRequest1)
+      call VTe(VTHallo)
+
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,
+     .             ij_begin+2*iip1,ij_end-2*iip1)
+
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest1)
+      call VTe(VTHallo)
+
+      call vlyqs_p(zq,pente_max,zm,mv,qsat)
+
+      call vlz_p(zq,pente_max,zm,mw,ij_begin,ij_begin+2*iip1-1)
+      call vlz_p(zq,pente_max,zm,mw,ij_end-2*iip1+1,ij_end)
+
+      call VTb(VTHallo)
+      call Register_Hallo(zq,ip1jmp1,llm,2,2,2,2,MyRequest2)
+      call Register_Hallo(zm,ip1jmp1,llm,1,1,1,1,MyRequest2)
+      call SendRequest(MyRequest2)
+      call VTe(VTHallo)
+
+      call vlz_p(zq,pente_max,zm,mw,ij_begin+2*iip1,ij_end-2*iip1)
+
+      call VTb(VTHallo)
+      call WaitRecvRequest(MyRequest2)
+      call VTe(VTHallo)
+      
+      call vlyqs_p(zq,pente_max,zm,mv,qsat)
+
+
+      call vlxqs_p(zq,pente_max,zm,mu,qsat,ij_begin,ij_end)
+
+
+      ijb=ij_begin
+      ije=ij_end
+
+      DO l=1,llm
+         DO ij=ijb,ije
+           q(ij,l)=zq(ij,l)
+         ENDDO
+      ENDDO
+      
+      DO l=1,llm
+         DO ij=ijb,ije-iip1+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      call WaitSendRequest(MyRequest1) 
+      call WaitSendRequest(MyRequest2)
+
+      RETURN
+      END
+      SUBROUTINE vlxqs_p(q,pente_max,masse,u_m,qsat,ijb_x,ije_x)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c
+c   --------------------------------------------------------------------
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm )
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      REAL      SSUM
+
+
+      INTEGER ijb,ije,ijb_x,ije_x
+      
+
+c   calcul de la pente a droite et a gauche de la maille
+
+c      ijb=ij_begin
+c      ije=ij_end
+
+      ijb=ijb_x
+      ije=ije_x
+        
+      if (pole_nord.and.ijb==1) ijb=ijb+iip1
+      if (pole_sud.and.ije==ip1jmp1)  ije=ije-iip1
+      
+      IF (pente_max.gt.-1.e-5) THEN
+c     IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+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)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=ijb,ije
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=ijb+1,ije
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=ijb+1,ije
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+c$OMP END DO NOWAIT
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+         DO l = 1, llm
+            DO ij=ijb,ije-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=ijb+iip1-1,ije,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=ijb+1,ije
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+c$OMP END DO NOWAIT
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb+iip1-1,ije,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+
+         DO ij=ijb,ije
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+c$OMP END DO NOWAIT
+      
+      if (pole_nord) THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm      
+          iadvplus(1:iip1,l)=0
+        ENDDO
+c$OMP END DO NOWAIT
+      endif
+      
+      if (pole_sud)  THEN
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm 
+	  iadvplus(ip1jm+1:ip1jmp1,l)=0
+        ENDDO
+c$OMP END DO NOWAIT
+      endif
+      	
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c--pas encore modification sur Qsat
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      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)=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),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+#else
+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$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)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij,l)+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)
+             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))
+          ENDIF
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+#endif
+
+
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         DO ij=ijb,ije-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       DO ij=ijb+iip1-1,ije,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c   pas d'influence de la pression saturante (pour l'instant)
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+         nl(l)=0
+         DO ij=ijb,ije
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+c$OMP END DO NOWAIT
+
+cym ATTENTION ICI en OpenMP reduction pas forcement nécessaire
+cym      IF(n0.gt.1) THEN
+cym        IF(n0.gt.0) THEN
+ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+ccc     &       ,'contenu de la maille : ',n0
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=ijb,ije
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     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)
+                        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))
+                  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)
+                        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))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+c$OMP END DO NOWAIT
+cym      ENDIF  ! n0.gt.0 
+
+
+
+c   bouclage en latitude
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        DO ij=ijb+iip1-1,ije,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+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
+         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
+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)
+
+
+      RETURN
+      END
+      SUBROUTINE vlyqs_p(q,pente_max,masse,masse_adv_v,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     qsat 	       est   un argument de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      USE parallel
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical first
+      SAVE first
+c$OMP THREADPRIVATE(first)
+      REAL convpn,convps,convmpn,convmps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon)
+c$OMP THREADPRIVATE(airej2,airejjm)
+c
+c
+      REAL      SSUM
+
+      DATA first/.true./
+      INTEGER ijb,ije
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      if (pole_nord) then
+        DO i = 1, iim
+          airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+        ENDDO
+        qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      endif
+      
+      if (pole_sud) then
+        DO i = 1, iim
+          airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+        ENDDO
+        qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+      endif
+
+
+c   calcul des pentes aux points v
+
+      ijb=ij_begin-2*iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+
+c   calcul des pentes aux points scalaires
+
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+      
+      DO ij=ijb,ije
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+      
+      IF (pole_nord) THEN
+
+c   calcul des pentes aux poles
+        DO ij=1,iip1
+           dyq(ij,l)=qpns-q(ij+iip1,l)
+        ENDDO
+
+c   filtrage de la derivee        
+        dyn1=0.
+        dyn2=0.
+        DO ij=1,iim
+          dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+          dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+        ENDDO
+        DO ij=1,iip1
+          dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+        ENDDO
+
+c   calcul des pentes limites aux poles
+        fn=1.
+        DO ij=1,iim
+          IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+          ENDIF
+        ENDDO
+      
+        DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+        ENDDO
+	  
+      ENDIF
+      
+      IF (pole_sud) THEN
+
+        DO ij=1,iip1
+           dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+        ENDDO
+
+        dys1=0.
+        dys2=0.
+
+        DO ij=1,iim
+          dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+          dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+        ENDDO
+
+        DO ij=1,iip1
+          dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+        ENDDO
+        
+c   calcul des pentes limites aux poles	
+        fs=1.
+        DO ij=1,iim
+        IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+        ENDIF
+        ENDDO
+    
+        DO ij=1,iip1
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+        ENDDO
+	
+      ENDIF
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+      ijb=ij_begin-iip1
+      ije=ij_end+iip1
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+
+      DO ij=ijb,ije
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin-iip1
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+       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)))
+         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)) )
+         ENDIF
+          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+c$OMP END DO NOWAIT
+
+      ijb=ij_begin
+      ije=ij_end
+      if (pole_nord) ijb=ij_begin+iip1
+      if (pole_sud)  ije=ij_end-iip1
+
+c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      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
+c.-. ancienne version
+
+         IF (pole_nord) THEN
+
+           convpn=SSUM(iim,qbyv(1,l),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)=newmasse
+           ENDDO
+	 
+	 ENDIF
+         
+	 IF (pole_sud) THEN
+	 
+	   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)=newmasse
+           ENDDO
+	 
+	 ENDIF
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*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        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*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        ENDDO
+c._. fin nouvelle version
+      ENDDO
+c$OMP END DO NOWAIT
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/wrgrads.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/wrgrads.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/wrgrads.F	(revision 984)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+      subroutine wrgrads(if,nl,field,name,titlevar)
+      implicit none
+
+c   Declarations
+c    if indice du fichier
+c    nl nombre de couches
+c    field   champ
+c    name    petit nom
+c    titlevar   Titre
+
+#include "gradsdef.h"
+
+c   arguments
+      integer if,nl
+      real field(imx*jmx*lmx)
+      character*10 name,file
+      character*10 titlevar
+
+c   local
+
+      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
+
+      logical writectl
+
+
+      writectl=.false.
+
+      print*,if,iid(if),jid(if),ifd(if),jfd(if)
+      iii=iid(if)
+      iji=jid(if)
+      iif=ifd(if)
+      ijf=jfd(if)
+      im=iif-iii+1
+      jm=ijf-iji+1
+      lm=lmd(if)
+
+      print*,'im,jm,lm,name,firsttime(if)'
+      print*,im,jm,lm,name,firsttime(if)
+
+      if(firsttime(if)) then
+         if(name.eq.var(1,if)) then
+            firsttime(if)=.false.
+            ivar(if)=1
+         print*,'fin de l initialiation de l ecriture du fichier'
+         print*,file
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+         else
+            ivar(if)=ivar(if)+1
+            nvar(if)=ivar(if)
+            var(ivar(if),if)=name
+            tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
+            nld(ivar(if),if)=nl
+            print*,'initialisation ecriture de ',var(ivar(if),if)
+            print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+      print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+      print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      do l=1,nl
+         irec(if)=irec(if)+1
+c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+         write(unit(if)+1,rec=irec(if))
+     s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
+     s   ,i=iii,iif),j=iji,ijf)
+      enddo
+      if (writectl) then
+
+      file=fichier(if)
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      open(unit(if),file=file(1:lnblnk(file))//'.ctl'
+     &         ,form='formatted',status='unknown')
+      write(unit(if),'(a5,1x,a40)')
+     &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
+
+      write(unit(if),'(a12)') 'UNDEF 1.0E30'
+      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+      write(unit(if),'(a4,i10,a30)')
+     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+      do iv=1,nvar(if)
+c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
+     &     ,99,tvar(iv,if)
+      enddo
+      write(unit(if),'(a7)') 'ENDVARS'
+c
+1000  format(a5,3x,i4,i3,1x,a39)
+
+      close(unit(if))
+
+      endif ! writectl
+
+      return
+
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/write_field_p.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/write_field_p.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/write_field_p.F90	(revision 984)
@@ -0,0 +1,73 @@
+module write_field_p
+implicit none
+  
+  interface WriteField_p
+    module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p
+  end interface WriteField_p
+  
+  contains
+  
+  subroutine write_field1D_p(name,Field)
+    USE parallel
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1)))
+    New_Field(:)=Field(:)
+    call Gather_Field(New_Field,dim(1),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+    end subroutine write_field1D_p
+
+  subroutine write_field2D_p(name,Field)
+    USE parallel
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2)))
+    New_Field(:,:)=Field(:,:)
+    call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+     
+  end subroutine write_field2D_p
+  
+  subroutine write_field3D_p(name,Field)
+    USE parallel
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2),Dim(3)))
+    New_Field(:,:,:)=Field(:,:,:)
+    call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0)
+    
+   if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+  end subroutine write_field3D_p  
+
+end module write_field_p
+  
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/write_grads_dyn.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/write_grads_dyn.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/write_grads_dyn.h	(revision 984)
@@ -0,0 +1,31 @@
+!
+! $Header$
+!
+      if (callinigrads) then
+
+         string10='dyn'
+         call inigrads(1,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtvr*iperiod,string10,'dyn_zon ')
+
+        callinigrads=.false.
+
+
+      endif
+
+      string10='ps'
+      CALL wrgrads(1,1,ps,string10,string10)
+
+      string10='u'
+      CALL wrgrads(1,llm,unat,string10,string10)
+      string10='v'
+      CALL wrgrads(1,llm,vnat,string10,string10)
+      string10='teta'
+      CALL wrgrads(1,llm,teta,string10,string10)
+      do iq=1,nqmx
+         string10='q'
+         write(string10(2:2),'(i1)') iq
+         CALL wrgrads(1,llm,q(:,:,iq),string10,string10)
+      enddo
+
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/writedynav_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/writedynav_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/writedynav_p.F	(revision 984)
@@ -0,0 +1,165 @@
+!
+! $Header$
+!
+      subroutine writedynav_p( histid, nq, time, vcov, 
+     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
+
+      USE ioipsl
+      USE parallel
+      USE misc_mod
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      nqmx: nombre maxi de traceurs
+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   Sortie:
+C      fileid: ID du fichier netcdf cree
+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 "advtrac.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, nq
+      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,nq)
+      integer time
+
+
+C   Variables locales
+C
+      integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
+      real us(ip1jmp1,llm), vs(ip1jmp1,llm)
+      real tm(ip1jmp1,llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) 
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+      
+      ndex3d = 0
+      ndex2d = 0
+      ok_sync = .TRUE.
+      us = 999.999
+      vs = 999.999
+      tm = 999.999
+      vnat = 999.999
+      unat = 999.999
+      itau_w = itau_dyn + time
+
+C Passage aux composantes naturelles du vent
+      call covnat_p(llm, ucov, vcov, unat, vnat)
+
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U scalaire
+C
+      call gr_u_scal_p(llm, unat, us)
+      
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+      
+      call histwrite(histid, 'u', itau_w, us(ijb:ije,:), 
+     .               iip1*jjn*llm, ndex3d)
+C
+C  Vents V scalaire
+C
+      if (pole_sud) ije=jj_end-iip1
+      if (pole_sud) jjn=jj_nb-1
+      
+      call gr_v_scal_p(llm, vnat, vs)
+      call histwrite(histid, 'v', itau_w, vs(ijb::ije,:), 
+     .               iip1*jjn*llm, ndex3d)
+C
+C  Temperature potentielle moyennee
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+      
+      call histwrite(histid, 'theta', itau_w, teta(ijb::ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Temperature moyennee
+C
+      do ll=1,llm
+        do ii = ijb, ije
+          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+        enddo
+      enddo
+      
+      call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
+     .                iip1*jjn*llm, ndex3d)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), 
+     .                   iip1*jjn*llm, ndex3d)
+        enddo
+C
+C  Masse
+C
+       call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1),
+     .                iip1*jjn, ndex2d)
+C
+C  Pression au sol
+C
+       call histwrite(histid, 'ps', itau_w, ps(ijb:ije), 
+     .                 iip1*jjn, ndex2d)
+C
+C  Geopotentiel au sol
+C
+       call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+     .                 iip1*jjn, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) call histsync(histid)
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/dyn3dpar/writehist_p.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/dyn3dpar/writehist_p.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/dyn3dpar/writehist_p.F	(revision 984)
@@ -0,0 +1,148 @@
+!
+! $Header$
+!
+      subroutine writehist_p( histid, histvid, nq, time, vcov, 
+     ,                          ucov,teta,phi,q,masse,ps,phis)
+
+      USE ioipsl
+      USE parallel
+      USE misc_mod
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      histvid:ID du fichier histoire pour les vents V (appele a disparaitre)
+C      nqmx: nombre maxi de traceurs
+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   Sortie:
+C      fileid: ID du fichier netcdf cree
+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 "advtrac.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, nq, histvid
+      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,nq)
+      integer time
+
+
+C   Variables locales
+C
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+C
+C  Initialisations
+C
+      if (adjust) return
+     
+    
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
+      ok_sync =.TRUE.
+      itau_w = itau_dyn + time
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+          
+      call histwrite(histid, 'ucov', itau_w, ucov, 
+     .               iip1*jjn*llm, ndexu)
+
+C
+C  Vents V
+C
+      if (pole_sud) ije=jj_end-iip1
+      if (pole_sud) jjn=jj_nb-1
+      
+      call histwrite(histvid, 'vcov', itau_w, vcov(ijb:ije,:), 
+     .               iip1*jjn*llm, ndexv)
+
+C
+C  Temperature potentielle
+C
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+
+      call histwrite(histid, 'teta', itau_w, teta(ijb:ije,:), 
+     .                iip1*jjn*llm, ndexu)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), 
+     .                iip1*jjn*llm, ndexu)
+C
+C  Traceurs
+C
+        DO iq=1,nq
+          call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), 
+     .                   iip1*jjn*llm, ndexu)
+        enddo
+C
+C  Masse
+C
+      call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1),
+     .               iip1*jjn, ndex2d)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', itau_w, ps(ijb:ije),
+     .               iip1*jjn, ndex2d)
+C
+C  Geopotentiel au sol
+C
+      call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+     .               iip1*jjn, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+      endif
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/filtrez/acc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/acc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/acc.F	(revision 984)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!
+        subroutine acc(vec,d,im)
+        dimension vec(im,im),d(im)
+        do j=1,im
+          do i=1,im
+            d(i)=vec(i,j)*vec(i,j)
+          enddo
+          sum=ssum(im,d,1)
+          sum=sqrt(sum)
+          do i=1,im
+            vec(i,j)=vec(i,j)/sum
+          enddo
+        enddo
+        return
+        end
Index: LMDZ4/tags/LF_20080728/libf/filtrez/coefils.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/coefils.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/coefils.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+      COMMON/coefils/jfiltnu,jfiltsu,jfiltnv,jfiltsv,sddu(iim),sddv(iim)
+     * ,unsddu(iim),unsddv(iim),coefilu(iim,jjm),coefilv(iim,jjm),
+     * modfrstu(jjm),modfrstv(jjm),eignfnu(iim,iim),eignfnv(iim,iim)
+     * ,coefilu2(iim,jjm),coefilv2(iim,jjm)
+c
+      INTEGER jfiltnu,jfiltsu,jfiltnv,jfiltsv,modfrstu,modfrstv
+      REAL    sddu,sddv,unsddu,unsddv,coefilu,coefilv,eignfnu,eignfnv
+      REAL    coefilu2,coefilv2
Index: LMDZ4/tags/LF_20080728/libf/filtrez/eigen.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/eigen.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/eigen.F	(revision 984)
@@ -0,0 +1,31 @@
+!
+! $Header$
+!
+      SUBROUTINE eigen( e,d)
+#include "dimensions.h"
+      dimension e( iim,iim ), d( iim )
+      dimension asm( iim )
+      im=iim
+c
+      DO 48 i = 1,im
+	 asm( i ) = d( im-i+1 )
+ 48   CONTINUE
+      DO 49 i = 1,iim
+	 d( i ) = asm( i )
+ 49   CONTINUE
+c
+c     PRINT 70,d
+ 70   FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/)
+		print *
+c
+      DO 51 i = 1,im
+	 DO 52 j = 1,im
+            asm( j ) = e( i , im-j+1 )
+ 52      CONTINUE
+	 DO 50 j = 1,im
+	    e( i,j ) = asm( j )
+ 50      CONTINUE
+ 51   CONTINUE
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/filtrez/eigen_sort.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/eigen_sort.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/eigen_sort.F	(revision 984)
@@ -0,0 +1,32 @@
+!
+! $Header$
+!
+          SUBROUTINE eigen_sort(d,v,n,np)
+          INTEGER n,np
+          REAL d(np),v(np,np)
+          INTEGER i,j,k
+          REAL p
+
+       DO i=1,n-1
+          k=i
+          p=d(i)
+        DO j=i+1,n
+           IF(d(j).ge.p) THEN
+            k=j
+            p=d(j)
+           ENDIF
+        ENDDO
+          
+        IF(k.ne.i) THEN
+          d(k)=d(i)
+          d(i)=p
+         DO j=1,n
+          p=v(j,i)
+          v(j,i)=v(j,k)
+          v(j,k)=p
+         ENDDO
+        ENDIF
+       ENDDO
+
+        RETURN
+        END
Index: LMDZ4/tags/LF_20080728/libf/filtrez/filtreg.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/filtreg.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/filtreg.F	(revision 984)
@@ -0,0 +1,300 @@
+!
+! $Header$
+!
+      SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire,
+     .   griscal ,iter)
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur: P. Le Van        07/10/97
+c   ------
+c
+c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+c                     pour l'operateur  Filtre    .
+c   ------
+c
+c   Arguments:
+c   ----------
+c
+c      nblat                 nombre de latitudes a filtrer
+c      nbniv                 nombre de niveaux verticaux a filtrer
+c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+c                            en sortie : champ filtre
+c      ifiltre               +1  Transformee directe
+c                            -1  Transformee inverse
+c                            +2  Filtre directe
+c                            -2  Filtre inverse
+c
+c      iaire                 1   si champ intensif
+c                            2   si champ extensif (pondere par les aires)
+c
+c      iter                  1   filtre simple
+c
+c=======================================================================
+c
+c
+c                      Variable Intensive
+c                ifiltre = 1     filtre directe
+c                ifiltre =-1     filtre inverse
+c
+c                      Variable Extensive
+c                ifiltre = 2     filtre directe
+c                ifiltre =-2     filtre inverse
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "parafilt.h"
+#include "coefils.h"
+c
+      INTEGER nlat,nbniv,ifiltre,iter
+      INTEGER i,j,l,k
+      INTEGER iim2,immjm
+      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+      REAL  champ( iip1,nlat,nbniv)
+      REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs
+      COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus)
+     ,             , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs)
+     ,             ,  matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus)
+      REAL  eignq(iim), sdd1(iim),sdd2(iim)
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+c
+
+      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
+     *    STOP'Pas de transformee simple dans cette version'
+
+      IF( iter.EQ. 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'
+     * , ' Utiliser old_filtreg et repasser !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ',
+     * ' sur la grille des scalaires !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     *,' corriger et repasser !'
+           STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+             PRINT  1111
+             STOP
+         ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 2
+             jffil1 = jfiltnu
+             jdfil2 = jfiltsu
+             jffil2 = jjm
+          END IF
+      ELSE
+          IF( nlat.NE.jjm )  THEN
+             PRINT  2222
+             STOP
+          ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 1
+             jffil1 = jfiltnv
+             jdfil2 = jfiltsv
+             jffil2 = jjm
+          END IF
+      END IF
+c
+c
+      DO 100  hemisph = 1, 2
+c
+      IF ( hemisph.EQ.1 )  THEN
+          jdfil = jdfil1
+          jffil = jffil1
+      ELSE
+          jdfil = jdfil2
+          jffil = jffil2
+      END IF
+
+ 
+      DO 50  l = 1, nbniv
+      DO 30  j = jdfil,jffil
+ 
+ 
+      DO  5  i = 1, iim
+      champ(i,j,l) = champ(i,j,l) * sdd1(i)
+   5  CONTINUE
+c
+
+      IF( hemisph. EQ. 1 )      THEN
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvn(1,1,j), 1, iim, champ(1,j,l), 1, eignq  , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO k = 1, iim
+      DO i = 1, iim
+         eignq(k) = eignq(k) + matrinvn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceun(1,1,j), 1, iim, champ(1,j,l), 1, eignq ,
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceun(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceun(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevn(1,1,j), 1, iim, champ(1,j,l), 1, eignq , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ELSE
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvs(1,1,j-jfiltsu+1),  1, iim, champ(1,j,l),1 ,  
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvs(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matrinvs(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceus(1,1,j-jfiltsu+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceus(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceus(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevs(1,1,j-jfiltsv+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevs(1,1,j-jfiltsv+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevs(k,i,j-jfiltsv+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ENDIF
+c
+      IF( ifiltre.EQ. 2 )  THEN
+        DO 15 i = 1, iim
+        champ( i,j,l ) = ( champ(i,j,l) + eignq(i) ) * sdd2(i)
+  15    CONTINUE
+      ELSE
+        DO 16 i=1,iim
+        champ( i,j,l ) = ( champ(i,j,l) - eignq(i) ) * sdd2(i)
+16      CONTINUE
+      ENDIF
+c
+      champ( iip1,j,l ) = champ( 1,j,l )
+c
+  30  CONTINUE
+c
+  50  CONTINUE
+c    
+ 100  CONTINUE
+c
+1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
+     *filtrer, sur la grille des scalaires'/)
+2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
+     *ltrer, sur la grille de V ou de Z'/)
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/filtrez/inifgn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/inifgn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/inifgn.F	(revision 984)
@@ -0,0 +1,106 @@
+!
+! $Header$
+!
+      SUBROUTINE inifgn(dv)
+c  
+c    ...  H.Upadyaya , O.Sharma  ... 
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "serre.h"
+
+c
+      REAL vec(iim,iim),vec1(iim,iim)
+      REAL dlonu(iim),dlonv(iim)
+      REAL du(iim),dv(iim),d(iim)
+      REAL pi
+      INTEGER i,j,k,imm1,nrot
+C
+#include "coefils.h"
+c
+      EXTERNAL SSUM, acc,eigen,jacobi
+      REAL SSUM
+c
+
+      imm1  = iim -1
+      pi = 2.* ASIN(1.)
+C
+      DO 5 i=1,iim
+       dlonu(i)=  xprimu( i )
+       dlonv(i)=  xprimv( i )
+   5  CONTINUE
+
+      DO 12 i=1,iim
+      sddv(i)   = SQRT(dlonv(i))
+      sddu(i)   = SQRT(dlonu(i))
+      unsddu(i) = 1./sddu(i)
+      unsddv(i) = 1./sddv(i)
+  12  CONTINUE
+C
+      DO 17 j=1,iim
+      DO 17 i=1,iim
+      vec(i,j)     = 0.
+      vec1(i,j)    = 0.
+      eignfnv(i,j) = 0.
+      eignfnu(i,j) = 0.
+  17  CONTINUE
+c
+c
+      eignfnv(1,1)    = -1.
+      eignfnv(iim,1)  =  1.
+      DO 20 i=1,imm1
+      eignfnv(i+1,i+1)= -1.
+      eignfnv(i,i+1)  =  1.
+  20  CONTINUE
+      DO 25 j=1,iim
+      DO 25 i=1,iim
+      eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j))
+  25  CONTINUE
+      DO 30 j=1,iim
+      DO 30 i=1,iim
+      eignfnu(i,j) = -eignfnv(j,i)
+  30  CONTINUE
+c
+#ifdef CRAY
+      CALL MXM(eignfnu,iim,eignfnv,iim,vec ,iim)
+      CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+#else
+      DO j = 1, iim
+      DO i = 1, iim
+        vec (i,j) = 0.0
+        vec1(i,j) = 0.0
+       DO k = 1, iim
+        vec (i,j) = vec(i,j)  + eignfnu(i,k) * eignfnv(k,j)
+        vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j)
+       ENDDO
+      ENDDO
+      ENDDO
+#endif
+
+c
+      CALL jacobi(vec,iim,iim,dv,eignfnv,nrot)
+      CALL acc(eignfnv,d,iim)
+      CALL eigen_sort(dv,eignfnv,iim,iim)
+c
+      CALL jacobi(vec1,iim,iim,du,eignfnu,nrot)
+      CALL acc(eignfnu,d,iim)
+      CALL eigen_sort(du,eignfnu,iim,iim)
+
+cc   ancienne version avec appels IMSL
+c
+c     CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim)
+c     CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+c     CALL EVCSF(iim,vec,iim,dv,eignfnv,iim)
+c     CALL acc(eignfnv,d,iim)
+c     CALL eigen(eignfnv,dv)
+c
+c     CALL EVCSF(iim,vec1,iim,du,eignfnu,iim)
+c     CALL acc(eignfnu,d,iim)
+c     CALL eigen(eignfnu,du)
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/filtrez/inifilr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/inifilr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/inifilr.F	(revision 984)
@@ -0,0 +1,591 @@
+!
+! $Header$
+!
+      SUBROUTINE inifilr
+c
+c    ... H. Upadhyaya, O.Sharma   ...
+c
+      IMPLICIT NONE
+c
+c     version 3 .....
+
+c     Correction  le 28/10/97    P. Le Van .
+c  -------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "parafilt.h"
+c  -------------------------------------------------------------------
+#include "comgeom.h"
+#include "coefils.h"
+#include "logic.h"
+#include "serre.h"
+
+      REAL  dlonu(iim),dlatu(jjm)
+      REAL  rlamda( iim ),  eignvl( iim )
+c
+
+      REAL    lamdamax,pi,cof
+      INTEGER i,j,modemax,imx,k,kf,ii
+      REAL dymin,dxmin,colat0
+      REAL eignft(iim,iim), coff
+      REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs
+      COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus)
+     ,             , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs)
+     ,             ,  matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus)
+#ifdef CRAY
+      INTEGER   ISMIN
+      EXTERNAL  ISMIN
+      INTEGER iymin 
+      INTEGER ixmineq
+#endif
+      EXTERNAL  inifgn
+c
+c ------------------------------------------------------------
+c   This routine computes the eigenfunctions of the laplacien
+c   on the stretched grid, and the filtering coefficients
+c      
+c  We designate:
+c   eignfn   eigenfunctions of the discrete laplacien
+c   eigenvl  eigenvalues
+c   jfiltn   indexof the last scalar line filtered in NH
+c   jfilts   index of the first line filtered in SH
+c   modfrst  index of the mode from where modes are filtered
+c   modemax  maximum number of modes ( im )
+c   coefil   filtering coefficients ( lamda_max*cos(rlat)/lamda )
+c   sdd      SQRT( dx )
+c      
+c     the modes are filtered from modfrst to modemax
+c      
+c-----------------------------------------------------------
+c
+
+       pi       = 2. * ASIN( 1. )
+
+       DO i = 1,iim
+        dlonu(i) = xprimu( i )
+       ENDDO
+c
+       CALL inifgn(eignvl)
+c
+        print *,' EIGNVL '
+        PRINT 250,eignvl
+250     FORMAT( 1x,5e13.6)
+c
+c compute eigenvalues and eigenfunctions
+c
+c
+c.................................................................
+c
+c  compute the filtering coefficients for scalar lines and 
+c  meridional wind v-lines
+c
+c  we filter all those latitude lines where coefil < 1
+c  NO FILTERING AT POLES
+c
+c  colat0 is to be used  when alpha (stretching coefficient)
+c  is set equal to zero for the regular grid case 
+c
+c    .......   Calcul  de  colat0   .........
+c     .....  colat0 = minimum de ( 0.5, min dy/ min dx )   ...
+c
+c
+      DO 45 j = 1,jjm
+         dlatu( j ) = rlatu( j ) - rlatu( j+1 )
+ 45   CONTINUE
+c
+#ifdef CRAY
+      iymin   = ISMIN( jjm, dlatu, 1 )
+      ixmineq = ISMIN( iim, dlonu, 1 )
+      dymin   = dlatu( iymin )
+      dxmin   = dlonu( ixmineq )
+#else
+      dxmin   =  dlonu(1)
+       DO  i  = 2, iim
+        dxmin = MIN( dxmin,dlonu(i) )
+       ENDDO
+      dymin  = dlatu(1)
+       DO j  = 2, jjm
+        dymin = MIN( dymin,dlatu(j) )
+       ENDDO
+#endif
+c
+c
+      colat0  =  MIN( 0.5, dymin/dxmin )
+c
+      IF( .NOT.fxyhypb.AND.ysinus )  THEN
+           colat0 = 0.6
+c         ...... a revoir  pour  ysinus !   .......
+           alphax = 0.
+      ENDIF
+c
+      PRINT 50, colat0,alphax
+  50  FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7)
+c
+      IF(alphax.EQ.1. )  THEN
+        PRINT *,' Inifilr  alphax doit etre  <  a 1.  Corriger '
+         STOP
+      ENDIF
+c
+      lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) )
+
+cc                        ... Correction  le 28/10/97  ( P.Le Van ) ..
+c
+      DO 71 i = 2,iim
+       rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) )
+ 71   CONTINUE
+c
+
+      DO 72 j = 1,jjm
+	    DO 73 i = 1,iim
+	    coefilu( i,j )  = 0.0
+	    coefilv( i,j )  = 0.0
+	    coefilu2( i,j ) = 0.0
+	    coefilv2( i,j ) = 0.0
+ 73     CONTINUE
+ 72   CONTINUE
+
+c
+c    ... Determination de jfiltnu,jfiltnv,jfiltsu,jfiltsv ....
+c    .........................................................
+c
+       modemax = iim
+
+cccc    imx = modemax - 4 * (modemax/iim)
+
+       imx  = iim
+c
+       PRINT *,' TRUNCATION AT ',imx
+c
+      DO 75 j = 2, jjm/2+1
+       cof = COS( rlatu(j) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatu(j) ).LT.1. ) jfiltnu= j
+        ENDIF
+
+       cof = COS( rlatu(jjp1-j+1) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatu(jjp1-j+1) ).LT.1. )
+     $      jfiltsu= jjp1-j+1
+        ENDIF
+ 75   CONTINUE
+c
+      DO 76 j = 1, jjm/2
+       cof = COS( rlatv(j) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatv(j) ).LT.1. ) jfiltnv= j
+        ENDIF
+
+       cof = COS( rlatv(jjm-j+1) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatv(jjm-j+1) ).LT.1. )
+     $       jfiltsv= jjm-j+1
+        ENDIF
+ 76   CONTINUE
+c                                 
+
+      if ( jfiltnu.LE.0 ) jfiltnu=1
+      IF( jfiltnu.GT. jjm/2 +1 )  THEN
+        PRINT *,' jfiltnu en dehors des valeurs acceptables ' ,jfiltnu
+        STOP
+      ENDIF
+
+      IF( jfiltsu.LE.0) jfiltsu=1
+      IF( jfiltsu.GT.  jjm  +1 )  THEN
+        PRINT *,' jfiltsu en dehors des valeurs acceptables ' ,jfiltsu
+        STOP
+      ENDIF
+
+      IF( jfiltnv.LE.0) jfiltnv=1
+      IF( jfiltnv.GT. jjm/2    )  THEN
+        PRINT *,' jfiltnv en dehors des valeurs acceptables ' ,jfiltnv
+        STOP
+      ENDIF
+
+      IF( jfiltsv.LE.0) jfiltsv=1
+      IF( jfiltsv.GT.     jjm  )  THEN
+        PRINT *,' jfiltsv en dehors des valeurs acceptables ' ,jfiltsv
+        STOP
+      ENDIF
+
+       PRINT *,' jfiltnv jfiltsv jfiltnu jfiltsu ' ,
+     *           jfiltnv,jfiltsv,jfiltnu,jfiltsu
+
+c                                 
+c   ... Determination de coefilu,coefilv,n=modfrstu,modfrstv ....
+c................................................................
+c
+c
+      DO 77 j = 1,jjm
+	  modfrstu( j ) = iim
+	  modfrstv( j ) = iim
+ 77   CONTINUE
+c
+      DO 84 j = 2,jfiltnu
+       DO 81 k = 2,modemax
+	     cof = rlamda(k) * COS( rlatu(j) )
+         IF ( cof .LT. 1. ) GOTO 82
+ 81    CONTINUE
+      GOTO 84
+ 82   modfrstu( j ) = k
+c
+	  kf = modfrstu( j )
+	   DO 83 k = kf , modemax
+        cof = rlamda(k) * COS( rlatu(j) )
+	    coefilu(k,j) = cof - 1.
+	    coefilu2(k,j) = cof*cof - 1.
+ 83    CONTINUE
+ 84   CONTINUE
+c                                 
+c
+      DO 89 j = 1,jfiltnv
+c
+       DO 86 k = 2,modemax
+	    cof = rlamda(k) * COS( rlatv(j) )
+         IF ( cof .LT. 1. ) GOTO 87
+ 86    CONTINUE
+      GOTO 89
+ 87   modfrstv( j ) = k
+c
+	   kf = modfrstv( j )
+	   DO 88 k = kf , modemax
+        cof = rlamda(k) * COS( rlatv(j) )
+	    coefilv(k,j) = cof - 1.
+	    coefilv2(k,j) = cof*cof - 1.
+ 88    CONTINUE
+c
+ 89    CONTINUE
+c
+      DO 94 j = jfiltsu,jjm
+       DO 91 k = 2,modemax
+	    cof = rlamda(k) * COS( rlatu(j) )
+         IF ( cof .LT. 1. ) GOTO 92
+ 91    CONTINUE
+      GOTO 94
+ 92   modfrstu( j ) = k
+c
+        kf = modfrstu( j )
+	 DO 93 k = kf , modemax
+          cof = rlamda(k) * COS( rlatu(j) )
+	  coefilu(k,j) = cof - 1.
+	  coefilu2(k,j) = cof*cof - 1.
+ 93      CONTINUE
+ 94    CONTINUE
+c                                 
+      DO 99 j = jfiltsv,jjm
+       DO 96 k = 2,modemax
+	     cof = rlamda(k) * COS( rlatv(j) )
+         IF ( cof .LT. 1. ) GOTO 97
+ 96    CONTINUE
+      GOTO 99
+ 97   modfrstv( j ) = k
+c
+       kf = modfrstv( j )
+	   DO 98 k = kf , modemax
+        cof = rlamda(k) * COS( rlatv(j) )
+	    coefilv(k,j) = cof - 1.
+	    coefilv2(k,j) = cof*cof - 1.
+ 98    CONTINUE
+ 99   CONTINUE
+c
+
+       IF(jfiltnv.GE.jjm/2 .OR. jfiltnu.GE.jjm/2)THEN
+
+         IF(jfiltnv.EQ.jfiltsv)jfiltsv=1+jfiltnv
+         IF(jfiltnu.EQ.jfiltsu)jfiltsu=1+jfiltnu
+
+          PRINT *,'jfiltnv jfiltsv jfiltnu jfiltsu' ,
+     *        jfiltnv,jfiltsv,jfiltnu,jfiltsu
+       ENDIF
+
+       PRINT *,'   Modes premiers  v  '
+       PRINT 334,modfrstv
+       PRINT *,'   Modes premiers  u  '
+       PRINT 334,modfrstu
+
+     
+      IF( nfilun.LT. jfiltnu )  THEN
+       PRINT *,' le parametre nfilun utilise pour la matrice ',
+     *   ' matriceun  est trop petit ! ' 
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnu
+        PRINT *,' Pour information, nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilun.GT. jfiltnu+ 2 )  THEN
+           PRINT *,' le parametre nfilun utilise pour la matrice ',
+     *' matriceun est trop grand ! Gachis de memoire ! ' 
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnu
+        PRINT *,' Pour information, nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+      IF( nfilus.LT. jjm - jfiltsu +1 )  THEN
+            PRINT *,' le parametre nfilus utilise pour la matrice ',
+     *   ' matriceus  est trop petit !  '
+       PRINT *,' Le changer dans parafilt.h et le mettre a  ',
+     * jjm - jfiltsu + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilus.GT. jjm - jfiltsu + 3 )  THEN
+           PRINT *,' le parametre nfilus utilise pour la matrice ',
+     * ' matriceus  est trop grand ! ' 
+       PRINT *,' Le changer dans parafilt.h et le mettre a  ' ,
+     * jjm - jfiltsu + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+      IF( nfilvn.LT. jfiltnv )  THEN
+            PRINT *,' le parametre nfilvn utilise pour la matrice ',
+     *   ' matricevn  est trop petit ! '  
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnv
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilvn.GT. jfiltnv+ 2 )  THEN
+           PRINT *,' le parametre nfilvn utilise pour la matrice ',
+     *' matricevn est trop grand !  Gachis de memoire ! ' 
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnv
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+      IF( nfilvs.LT. jjm - jfiltsv +1 )  THEN
+            PRINT *,' le parametre nfilvs utilise pour la matrice ',
+     *   ' matricevs  est trop petit !  Le changer dans parafilt.h '
+       PRINT *,' Le changer dans parafilt.h et le mettre a  '
+     * , jjm - jfiltsv + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilvs.GT. jjm - jfiltsv + 3 )  THEN
+           PRINT *,' le parametre nfilvs utilise pour la matrice ',
+     * ' matricevs  est trop grand ! Gachis de memoire ! '
+       PRINT *,' Le changer dans parafilt.h et le mettre a  '
+     *   ,  jjm - jfiltsv + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+
+c  
+c   ...................................................................
+c
+c   ... Calcul de la matrice filtre 'matriceu'  pour les champs situes
+c                       sur la grille scalaire                 ........
+c   ...................................................................
+c
+        DO j = 2, jfiltnu
+
+         DO i=1,iim
+          coff = coefilu(i,j)
+          IF( i.LT.modfrstu(j) ) coff = 0.
+           DO k=1,iim
+            eignft(i,k) = eignfnv(k,i) * coff
+           ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM( eignfnv,iim,eignft,iim,matriceun(1,1,j),iim )
+#else
+#ifdef BLAS
+         CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $   eignfnv, iim, eignft, iim, 0.0, matriceun(1,1,j), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matriceun(i,k,j) = 0.0
+            DO ii = 1, iim
+               matriceun(i,k,j) = matriceun(i,k,j)
+     .                          + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+        DO j = jfiltsu, jjm
+
+         DO i=1,iim
+          coff = coefilu(i,j)
+          IF( i.LT.modfrstu(j) ) coff = 0.
+            DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+            ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM(eignfnv,iim,eignft,iim,matriceus(1,1,j-jfiltsu+1),iim)
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $           eignfnv, iim, eignft, iim, 0.0, 
+     $           matriceus(1,1,j-jfiltsu+1), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matriceus(i,k,j-jfiltsu+1) = 0.0
+            DO ii = 1, iim
+               matriceus(i,k,j-jfiltsu+1) = matriceus(i,k,j-jfiltsu+1)
+     .                                    + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+c   ...................................................................
+c
+c   ... Calcul de la matrice filtre 'matricev'  pour les champs situes
+c                       sur la grille   de V ou de Z           ........
+c   ...................................................................
+c
+        DO j = 1, jfiltnv
+
+         DO i = 1, iim
+          coff = coefilv(i,j)
+          IF( i.LT.modfrstv(j) ) coff = 0.
+           DO k = 1, iim
+            eignft(i,k) = eignfnu(k,i) * coff
+           ENDDO
+         ENDDO
+#ifdef CRAY
+          CALL MXM( eignfnu,iim,eignft,iim,matricevn(1,1,j),iim )
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $     eignfnu, iim, eignft, iim, 0.0, matricevn(1,1,j), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matricevn(i,k,j) = 0.0
+            DO ii = 1, iim
+               matricevn(i,k,j) = matricevn(i,k,j)
+     .                          + eignfnu(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+        DO j = jfiltsv, jjm
+
+         DO i = 1, iim
+          coff = coefilv(i,j)
+          IF( i.LT.modfrstv(j) ) coff = 0.
+            DO k = 1, iim
+             eignft(i,k) = eignfnu(k,i) * coff
+            ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM(eignfnu,iim,eignft,iim,matricevs(1,1,j-jfiltsv+1),iim)
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $           eignfnu, iim, eignft, iim, 0.0, 
+     $           matricevs(1,1,j-jfiltsv+1), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matricevs(i,k,j-jfiltsv+1) = 0.0
+            DO ii = 1, iim
+               matricevs(i,k,j-jfiltsv+1) = matricevs(i,k,j-jfiltsv+1)
+     .                          + eignfnu(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+c   ...................................................................
+c
+c   ... Calcul de la matrice filtre 'matrinv'  pour les champs situes
+c              sur la grille scalaire , pour le filtre inverse ........
+c   ...................................................................
+c
+        DO j = 2, jfiltnu
+
+         DO i = 1,iim
+          coff = coefilu(i,j)/ ( 1. + coefilu(i,j) )
+          IF( i.LT.modfrstu(j) ) coff = 0.
+           DO k=1,iim
+            eignft(i,k) = eignfnv(k,i) * coff
+           ENDDO
+         ENDDO
+#ifdef CRAY
+          CALL MXM( eignfnv,iim,eignft,iim,matrinvn(1,1,j),iim )
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $     eignfnv, iim, eignft, iim, 0.0, matrinvn(1,1,j), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matrinvn(i,k,j) = 0.0
+            DO ii = 1, iim
+               matrinvn(i,k,j) = matrinvn(i,k,j)
+     .                          + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+        DO j = jfiltsu, jjm
+
+         DO i = 1,iim
+          coff = coefilu(i,j) / ( 1. + coefilu(i,j) )
+          IF( i.LT.modfrstu(j) ) coff = 0.
+            DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+            ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM(eignfnv,iim,eignft,iim,matrinvs(1,1,j-jfiltsu+1),iim)
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $ eignfnv, iim, eignft, iim, 0.0, matrinvs(1,1,j-jfiltsu+1), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matrinvs(i,k,j-jfiltsu+1) = 0.0
+            DO ii = 1, iim
+               matrinvs(i,k,j-jfiltsu+1) = matrinvs(i,k,j-jfiltsu+1)
+     .                          + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+c   ...................................................................
+
+c
+334    FORMAT(1x,24i3)
+755    FORMAT(1x,6f10.3,i3)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/filtrez/jacobi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/jacobi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/jacobi.F	(revision 984)
@@ -0,0 +1,97 @@
+!
+! $Header$
+!
+      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
+      PARAMETER (NMAX=400)
+      DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)
+      IF (n.gt.nmax) THEN
+         print*, 'n, nmax=', n, nmax
+         print*, 'Surdimensionnement insuffisant dans jacobi'
+         CALL abort
+      ENDIF
+      DO 12 IP=1,N
+        DO 11 IQ=1,N
+          V(IP,IQ)=0.
+11      CONTINUE
+        V(IP,IP)=1.
+12    CONTINUE
+      DO 13 IP=1,N
+        B(IP)=A(IP,IP)
+        D(IP)=B(IP)
+        Z(IP)=0.
+13    CONTINUE
+      NROT=0
+      DO 24 I=1,50
+        SM=0.
+        DO 15 IP=1,N-1
+          DO 14 IQ=IP+1,N
+            SM=SM+ABS(A(IP,IQ))
+14        CONTINUE
+15      CONTINUE
+        IF(SM.EQ.0.)RETURN
+        IF(I.LT.4)THEN
+          TRESH=0.2*SM/N**2
+        ELSE
+          TRESH=0.
+        ENDIF
+        DO 22 IP=1,N-1
+          DO 21 IQ=IP+1,N
+            G=100.*ABS(A(IP,IQ))
+            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP)))
+     *         .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
+              A(IP,IQ)=0.
+            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
+              H=D(IQ)-D(IP)
+              IF(ABS(H)+G.EQ.ABS(H))THEN
+                T=A(IP,IQ)/H
+              ELSE
+                THETA=0.5*H/A(IP,IQ)
+                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
+                IF(THETA.LT.0.)T=-T
+              ENDIF
+              C=1./SQRT(1+T**2)
+              S=T*C
+              TAU=S/(1.+C)
+              H=T*A(IP,IQ)
+              Z(IP)=Z(IP)-H
+              Z(IQ)=Z(IQ)+H
+              D(IP)=D(IP)-H
+              D(IQ)=D(IQ)+H
+              A(IP,IQ)=0.
+              DO 16 J=1,IP-1
+                G=A(J,IP)
+                H=A(J,IQ)
+                A(J,IP)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+16            CONTINUE
+              DO 17 J=IP+1,IQ-1
+                G=A(IP,J)
+                H=A(J,IQ)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+17            CONTINUE
+              DO 18 J=IQ+1,N
+                G=A(IP,J)
+                H=A(IQ,J)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(IQ,J)=H+S*(G-H*TAU)
+18            CONTINUE
+              DO 19 J=1,N
+                G=V(J,IP)
+                H=V(J,IQ)
+                V(J,IP)=G-S*(H+G*TAU)
+                V(J,IQ)=H+S*(G-H*TAU)
+19            CONTINUE
+              NROT=NROT+1
+            ENDIF
+21        CONTINUE
+22      CONTINUE
+        DO 23 IP=1,N
+          B(IP)=B(IP)+Z(IP)
+          D(IP)=B(IP)
+          Z(IP)=0.
+23      CONTINUE
+24    CONTINUE
+      STOP '50 iterations should never happen'
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c        PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+c      PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+
+c 96 72 19 non-zoom:
+      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
+c        PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 )
+c
+c
+c      Ici , on a exagere  les nombres de lignes de latitudes a filtrer .
+c
+c      La premiere fois que  le Gcm  rentrera  dans le Filtre ,
+c
+c      il indiquera  les bonnes valeurs  de  nfilun , nflius, nfilvn  et 
+c
+c      nfilvs  a  mettre .  Il suffira alors de changer ces valeurs dans
+c
+c      Parameter  ci-dessus  et de relancer  le  run .  
+
Index: LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h_192x142x29
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h_192x142x29	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h_192x142x29	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c        PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+c      PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+
+c 96 72 19 non-zoom:
+c     PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
+c 192 142 29 non-zoom:
+      PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+c
+c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
+c        PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 )
+c
+c
+c      Ici , on a exagere  les nombres de lignes de latitudes a filtrer .
+c
+c      La premiere fois que  le Gcm  rentrera  dans le Filtre ,
+c
+c      il indiquera  les bonnes valeurs  de  nfilun , nflius, nfilvn  et 
+c
+c      nfilvs  a  mettre .  Il suffira alors de changer ces valeurs dans
+c
+c      Parameter  ci-dessus  et de relancer  le  run .  
+
Index: LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h_96x71x19
===================================================================
--- LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h_96x71x19	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/filtrez/parafilt.h_96x71x19	(revision 984)
@@ -0,0 +1,46 @@
+!
+! $Header$
+!
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c        PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+c      PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+
+cIM 96 72 19 non-zoom:
+c 96 71 19 non-zoom:
+      PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
+c 192 142 29 non-zoom:
+c     PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+c
+c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
+c        PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 )
+c
+c
+c      Ici , on a exagere  les nombres de lignes de latitudes a filtrer .
+c
+c      La premiere fois que  le Gcm  rentrera  dans le Filtre ,
+c
+c      il indiquera  les bonnes valeurs  de  nfilun , nflius, nfilvn  et 
+c
+c      nfilvs  a  mettre .  Il suffira alors de changer ces valeurs dans
+c
+c      Parameter  ci-dessus  et de relancer  le  run .  
+
Index: LMDZ4/tags/LF_20080728/libf/grid/dimension/makdim
===================================================================
--- LMDZ4/tags/LF_20080728/libf/grid/dimension/makdim	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/grid/dimension/makdim	(revision 984)
@@ -0,0 +1,71 @@
+nqmx=$1
+shift
+for i in $* ; do
+   list=$list.$i
+done
+fichdim=dimensions${list}.t${nqmx}
+
+if [ ! -f $fichdim ] ; then
+# si le fichier de dimensions n'existe pas, on le cree
+
+  if [ $# -ge 3 ] ; then
+     im=$1
+     jm=$2
+     lm=$3
+     n2=$1
+     ndm=1
+
+# Le test suivant est commente car il est inutile avec le nouveau 
+# filtre filtrez. Attention avec le "vieux" filtre (F. Forget,11/1994)
+#
+#     while [ "$n2" -gt 2 ]; do
+#       n2=`expr $n2 / 2`
+#       ndm=`expr $ndm + 1`
+#       echo $n2
+#    done
+#    if [ "$n2" != 2 ] ; then
+#       echo le nombre de longitude doit etre une puissance de 2
+#       exit
+#    fi
+
+
+  else if [ $# -ge 2 ] ; then
+      im=1
+      jm=$1
+      lm=$2
+      ndm=1
+  else if [ $# -ge 1 ] ; then
+      im=1
+      jm=1
+      lm=$1
+      ndm=1
+  else
+         echo il faut au moins une dimension
+         exit
+  fi
+fi
+fi
+
+cat << EOF > $fichdim
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER iim,jjm,llm,ndm
+
+      PARAMETER (iim= $im,jjm=$jm,llm=$lm,ndm=$ndm)
+
+      integer nqmx
+      parameter (nqmx=$nqmx)
+
+!-----------------------------------------------------------------------
+EOF
+
+fi
+
+\rm ../dimensions.h
+tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h )
Index: LMDZ4/tags/LF_20080728/libf/grid/fxy_new.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/grid/fxy_new.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/grid/fxy_new.h	(revision 984)
@@ -0,0 +1,27 @@
+!
+! $Header$
+!
+c--------------------------------------------------------------
+         REAL ripx
+         REAL fx,fxprim,fy,fyprim,ri,rj,bigy
+c
+c....stretching in x...
+c
+        ripx(  ri )= (ri-1.0) *2.*pi/FLOAT(iim) 
+        fx  (  ri )= ripx(ri) + transx  +
+     *         alphax * SIN( ripx(ri)+transx-pxo ) - pi
+        fxprim(ri) = 2.*pi/FLOAT(iim)  *
+     *        ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) )
+
+c....stretching in y...
+c
+        bigy(rj)   = 2.* (FLOAT(jjp1)-rj ) *pi/jjm
+        fy(rj)     =  ( bigy(rj) + transy  +
+     *        alphay * SIN( bigy(rj)+transy-pyo ) ) /2.  - pi/2.
+        fyprim(rj) = ( pi/jjm ) * ( 1.+
+     *           alphay * COS( bigy(rj)+transy-pyo ) )
+
+c       fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj-
+c     *  transy ))
+c       fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy)) 
+c--------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/grid/fxy_reg.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/grid/fxy_reg.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/grid/fxy_reg.h	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy    ( rj ) =    pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) +  1. - rj  )
+      fyprim( rj ) =    pi/FLOAT(jjm)
+
+c     fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
+c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/FLOAT(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/grid/fxy_sin.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/grid/fxy_sin.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/grid/fxy_sin.h	(revision 984)
@@ -0,0 +1,42 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
+      fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/FLOAT(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/grid/fxyprim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/grid/fxyprim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/grid/fxyprim.h	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy    ( rj ) =    pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) +  1. - rj  )
+      fyprim( rj ) =    pi/FLOAT(jjm)
+
+c     fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
+c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/FLOAT(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/FCTTRE.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/FCTTRE.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/FCTTRE.h	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!     ------------------------------------------------------------------
+!     This COMDECK includes the Thermodynamical functions for the cy39
+!       ECMWF Physics package.
+!       Consistent with YOMCST Basic physics constants, assuming the
+!       partial pressure of water vapour is given by a first order
+!       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
+!       in YOETHF
+!     ------------------------------------------------------------------
+      REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
+      REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
+      LOGICAL thermcep
+      PARAMETER (thermcep=.TRUE.)
+!
+      FOEEW ( PTARG,PDELARG ) = EXP (                                   &
+     &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)        &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+!
+      FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
+!
+      qsats(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (2.07023 - 0.00320991 * ptarg                       &
+     &           - 2484.896 / ptarg + 3.56654 * LOG10(ptarg))
+      qsatl(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (23.8319 - 2948.964 / ptarg                         &
+     &           - 5.028 * LOG10(ptarg)                                 &
+     &           - 29810.16 * EXP( - 0.0699382 * ptarg)                 &
+     &           + 25.21935 * EXP( - 2999.924 / ptarg))
+!
+      dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg         &
+     &                     +2484.896*LOG(10.)/ptarg**2                  &
+     &                     -0.00320991*LOG(10.))
+      dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)*                &
+     &                (2948.964/ptarg**2-5.028/LOG(10.)/ptarg           &
+     &                +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg)  &
+     &                +29810.16*0.0699382*EXP(-0.0699382*ptarg))
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOECUMF.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOECUMF.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOECUMF.h	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+C     ----------------------------------------------------------------
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C     ----------------------------------------------------------------
+C
+      COMMON /YOECUMF/
+     L                 LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV,
+     R                 ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,
+     R                 CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON
+C
+      LOGICAL          LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
+      REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
+      REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
+c$OMP THREADPRIVATE(/YOECUMF/)
+C
+*if (DOC,declared) <> 'UNKNOWN'
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C
+C     M.TIEDTKE       E. C. M. W. F.      18/1/89
+C
+C     NAME      TYPE      PURPOSE
+C     ----      ----      -------
+C
+C     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
+C     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
+C     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
+C     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
+C     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
+C     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+C     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
+C     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+C     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+C     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
+C     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
+C     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
+C     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+C     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
+C     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
+C                        FROM CLOUD WATER TO RAIN
+*ifend
+C     ----------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOEGWD.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOEGWD.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOEGWD.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+C     -----------------------------------------------------------------
+C*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+C     -----------------------------------------------------------------
+C
+      integer NKTOPG,NSTRA
+      real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+      real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC
+      COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+     *        ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC
+c$OMP THREADPRIVATE(/YOEGWD/)
+C
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOETHF.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOETHF.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOETHF.h	(revision 984)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
+!
+!     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
+!                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
+!                ICE(*R_IES*).
+!     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
+!     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
+!
+      REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
+      REAL RVTMP2, RHOH2O
+      COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES,    &
+     &               RVTMP2, RHOH2O
+!$OMP THREADPRIVATE(/YOETHF/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOMCST.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOMCST.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/YOMCST.h	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! A1.0 Fundamental constants
+      REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO
+! A1.1 Astronomical constants
+      REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
+! A1.1.bis Constantes concernant l'orbite de la Terre:
+      REAL R_ecc, R_peri, R_incl
+! A1.2 Geoide
+      REAL RA,RG,R1SA
+! A1.3 Radiation
+!     REAL RSIGMA,RI0
+      REAL RSIGMA
+! A1.4 Thermodynamic gas phase
+      REAL R,RMD,RMO3,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
+      REAL RKAPPA,RETV
+! A1.5,6 Thermodynamic liquid,solid phases
+      REAL RCW,RCS
+! A1.7 Thermodynamic transition of phase
+      REAL RLVTT,RLSTT,RLMLT,RTT,RATM
+! A1.8 Curve of saturation
+      REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
+      REAL RALPD,RBETD,RGAMD
+!
+      COMMON/YOMCST/RPI   ,RCLUM ,RHPLA ,RKBOL ,RNAVO                   &
+     &      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA                  &
+     &      ,R_ecc, R_peri, R_incl                                      &
+     &      ,RA    ,RG    ,R1SA                                         &
+     &      ,RSIGMA                                                     &
+     &      ,R     ,RMD   ,RMO3  ,RMV   ,RD    ,RV    ,RCPD             &
+     &      ,RCPV  ,RCVD  ,RCVV  ,RKAPPA,RETV                           &
+     &      ,RCW   ,RCS                                                 &
+     &      ,RLVTT ,RLSTT ,RLMLT ,RTT   ,RATM                           &
+     &      ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS            &
+     &      ,RALPD ,RBETD ,RGAMD
+!    ------------------------------------------------------------------
+!$OMP THREADPRIVATE(/YOMCST/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/aaam_bud.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/aaam_bud.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/aaam_bud.F	(revision 984)
@@ -0,0 +1,361 @@
+      subroutine aaam_bud (iam,nlon,nlev,rjour,rsec,
+     i                   rea,rg,ome,      
+     i                   plat,plon,phis,
+     i                   dragu,liftu,phyu,
+     i                   dragv,liftv,phyv,
+     i                   p, u, v,
+     o                   aam, torsfc)
+c
+      implicit none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 20031020
+c Object: Compute different terms of the axial AAAM Budget.
+C No outputs, every AAM quantities are written on the IAM
+C File. 
+c
+c Modif : I.Musat (LMD/CNRS) date : 20041020
+c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc",
+c but no write in the iam file.
+c
+C WARNING: Only valid for regular rectangular grids.
+C REMARK: CALL DANS PHYSIQ AFTER lift_noro:
+C        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+C    C               ra,rg,romega,
+C    C               rlat,rlon,pphis,
+C    C               zustrdr,zustrli,zustrph,
+C    C               zvstrdr,zvstrli,zvstrph,
+C    C               paprs,u,v)
+C
+C======================================================================
+c Explicit Arguments:
+c ==================
+c iam-----input-I-File number where AAMs and torques are written
+c                 It is a formatted file that has been opened
+c                 in physiq.F
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c rjour---input-R-Jour compte depuis le debut de la simu (run.def)
+c rsec----input-R-Seconde de la journee
+c rea-----input-R-Earth radius
+c rg------input-R-gravity constant
+c ome-----input-R-Earth rotation rate
+c plat ---input-R-Latitude en degres
+c plon ---input-R-Longitude en degres
+c phis ---input-R-Geopotential at the ground
+c dragu---input-R-orodrag stress (zonal)
+c liftu---input-R-orolift stress (zonal)
+c phyu----input-R-Stress total de la physique (zonal)
+c dragv---input-R-orodrag stress (Meridional)
+c liftv---input-R-orolift stress (Meridional)
+c phyv----input-R-Stress total de la physique (Meridional)
+c p-------input-R-Pressure (Pa) at model half levels
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c aam-----output-R-Axial Wind AAM (=raam(3))
+c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                iim*(jjm-1)+2 for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c dlat-----R: Latitude increment (Radians)
+c dlon-----R: Longitude increment (Radians)
+c raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c tmou-----R: Resolved Mountain torque (3 components)
+c tsso-----R: Parameterised Moutain drag torque (3 components)
+c tbls-----R: Parameterised Boundary layer torque (3 components)
+c
+c LOCAL ARRAY:
+c ===========
+c zs    ---R: Topographic height
+c ps    ---R: Surface Pressure  
+c ub    ---R: Barotropic wind zonal
+c vb    ---R: Barotropic wind meridional
+c zlat  ---R: Latitude in radians
+c zlon  ---R: Longitude in radians
+c======================================================================
+
+#include "dimensions.h"
+#include "dimphy.h"
+c
+c ARGUMENTS
+c
+      INTEGER iam,nlon,nlev
+      REAL rjour,rsec,rea,rg,ome
+      REAL plat(nlon),plon(nlon),phis(nlon)
+      REAL dragu(nlon),liftu(nlon),phyu(nlon)             
+      REAL dragv(nlon),liftv(nlon),phyv(nlon)             
+      REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev)
+c
+c Variables locales:
+c
+      INTEGER i,j,k,l
+      REAL xpi,hadley,hadday
+      REAL dlat,dlon
+      REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3)
+      integer iax
+cIM ajout aam, torsfc
+c aam = composante axiale du Wind AAM raam
+c torsfc = composante axiale de (tmou+tsso+tbls)
+      REAL aam, torsfc
+
+      REAL ZS(801,401),PS(801,401)
+      REAL UB(801,401),VB(801,401)
+      REAL SSOU(801,401),SSOV(801,401)
+      REAL BLSU(801,401),BLSV(801,401)
+      REAL ZLON(801),ZLAT(401)
+C
+C  PUT AAM QUANTITIES AT ZERO:
+C
+      if(iim+1.gt.801.or.jjm+1.gt.401)then
+      print *,' Pb de dimension dans aaam_bud'
+      stop
+      endif
+
+      xpi=acos(-1.)
+      hadley=1.e18
+      hadday=1.e18*24.*3600.
+      dlat=xpi/float(jjm)
+      dlon=2.*xpi/float(iim) 
+      
+      do iax=1,3
+      oaam(iax)=0.
+      raam(iax)=0.
+      tmou(iax)=0.
+      tsso(iax)=0.
+      tbls(iax)=0.
+      enddo
+
+C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
+
+C North pole values (j=1):
+ 
+      l=1
+
+        ub(1,1)=0.
+        vb(1,1)=0.
+        do k=1,nlev
+          ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+          vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+        enddo
+
+          zlat(1)=plat(l)*xpi/180.
+
+        do i=1,iim+1
+
+          zs(i,1)=phis(l)/rg
+          ps(i,1)=p(l,1)
+          ub(i,1)=ub(1,1)                             
+          vb(i,1)=vb(1,1)                             
+          ssou(i,1)=dragu(l)+liftu(l)
+          ssov(i,1)=dragv(l)+liftv(l)
+          blsu(i,1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,1)=phyv(l)-dragv(l)-liftv(l)
+
+        enddo
+
+
+      do j = 2,jjm
+
+C Values at Greenwich (Periodicity)
+
+      zs(iim+1,j)=phis(l+1)/rg
+      ps(iim+1,j)=p(l+1,1)
+          ssou(iim+1,j)=dragu(l+1)+liftu(l+1)
+          ssov(iim+1,j)=dragv(l+1)+liftv(l+1)
+          blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1)
+          blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1)
+      zlon(iim+1)=-plon(l+1)*xpi/180.
+      zlat(j)=plat(l+1)*xpi/180.
+
+      ub(iim+1,j)=0.
+      vb(iim+1,j)=0.
+         do k=1,nlev
+         ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         enddo
+      
+
+      do i=1,iim
+
+      l=l+1
+      zs(i,j)=phis(l)/rg
+      ps(i,j)=p(l,1)
+          ssou(i,j)=dragu(l)+liftu(l)
+          ssov(i,j)=dragv(l)+liftv(l)
+          blsu(i,j)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,j)=phyv(l)-dragv(l)-liftv(l)
+      zlon(i)=plon(l)*xpi/180.
+
+      ub(i,j)=0.
+      vb(i,j)=0.
+         do k=1,nlev
+         ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+         enddo
+
+      enddo
+
+      enddo
+
+
+C South Pole
+
+      l=l+1
+      ub(1,jjm+1)=0.
+      vb(1,jjm+1)=0.
+      do k=1,nlev
+         ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+      enddo
+      zlat(jjm+1)=plat(l)*xpi/180.
+
+      do i=1,iim+1
+      zs(i,jjm+1)=phis(l)/rg
+      ps(i,jjm+1)=p(l,1)
+          ssou(i,jjm+1)=dragu(l)+liftu(l)
+          ssov(i,jjm+1)=dragv(l)+liftv(l)
+          blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l)
+      ub(i,jjm+1)=ub(1,jjm+1)                               
+      vb(i,jjm+1)=vb(1,jjm+1)                                
+      enddo
+
+C
+C  MOMENT ANGULAIRE 
+C
+        DO j=1,jjm    
+        DO i=1,iim
+
+           raam(1)=raam(1)-rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +cos(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    +rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +sin(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (cos(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +cos(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(2)=raam(2)-rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +sin(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    -rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +cos(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (sin(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +sin(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(3)=raam(3)+rea**3*dlon*dlat*0.5*
+     c           (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1))
+
+           oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5*
+     c        (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1))
+
+        ENDDO
+        ENDDO
+
+C
+C COUPLE DES MONTAGNES:
+C
+
+        DO j=1,jjm
+        DO i=1,iim
+           tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+           tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+        ENDDO
+        ENDDO
+           
+        DO j=2,jjm 
+        DO i=1,iim
+           tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
+           tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
+           tmou(3)=tmou(3)-rea**2*dlat*0.5*
+     c  cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j))
+        ENDDO
+        ENDDO
+
+C
+C COUPLES DES DIFFERENTES FRICTION AU SOL:
+C
+        l=1
+        DO j=2,jjm
+        DO i=1,iim
+        l=l+1
+           tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *sin(zlon(i))
+
+           tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *cos(zlon(i))
+
+           tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *cos(zlat(j))
+
+           tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *sin(zlon(i))
+
+           tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *cos(zlon(i))
+
+           tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *cos(zlat(j))
+
+        ENDDO
+        ENDDO
+            
+
+c     write(*,*) 'AAM',rsec,
+c     write(*,*) 'AAM',rjour+rsec/86400.,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+
+c     write(iam,100)rjour+rsec/86400.,
+c    c      raam(1)/hadday,oaam(1)/hadday,
+c    c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
+c    c      raam(2)/hadday,oaam(2)/hadday,
+c    c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley 
+100   format(F12.5,15(1x,F12.5))
+
+c     write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1)
+c
+      aam=raam(3)
+      torsfc= tmou(3)+tsso(3)+tbls(3)
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/aeropt.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/aeropt.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/aeropt.F	(revision 984)
@@ -0,0 +1,134 @@
+!
+! $Header$
+!
+      SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl,
+     .            tau_ae, piz_ae, cg_ae, ai        )
+c
+      USE dimphy
+      IMPLICIT none
+c
+c
+c     
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev), t_seri(klon,klev)
+      REAL msulfate(klon,klev) ! masse sulfate ug SO4/m3  [ug/m^3]
+      REAL RHcl(klon,klev)     ! humidite relative ciel clair
+      REAL tau_ae(klon,klev,2) ! epaisseur optique aerosol
+      REAL piz_ae(klon,klev,2) ! single scattering albedo aerosol
+      REAL cg_ae(klon,klev,2)  ! asymmetry parameter aerosol
+      REAL ai(klon)            ! POLDER aerosol index 
+c
+c Local
+c
+      INTEGER i, k, inu
+      INTEGER RH_num, nbre_RH
+      PARAMETER (nbre_RH=12)
+      REAL RH_tab(nbre_RH)
+      REAL RH_MAX, DELTA, rh 
+      PARAMETER (RH_MAX=95.)
+      DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+      REAL zrho, zdz
+      REAL taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
+      REAL taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
+      REAL alpha_aer_sulfate(nbre_RH,5)   !--unit m2/g SO4
+      REAL alphasulfate      
+c
+c Proprietes optiques
+c
+      REAL alpha_aer(nbre_RH,2)   !--unit m2/g SO4
+      REAL cg_aer(nbre_RH,2)
+      DATA alpha_aer/.500130E+01,  .500130E+01,  .500130E+01,  
+     .               .500130E+01,  .500130E+01,  .616710E+01,  
+     .               .826850E+01,  .107687E+02,  .136976E+02,  
+     .               .162972E+02,  .211690E+02,  .354833E+02,  
+     .               .139460E+01,  .139460E+01,  .139460E+01,  
+     .               .139460E+01,  .139460E+01,  .173910E+01,  
+     .               .244380E+01,  .332320E+01,  .440120E+01,  
+     .               .539570E+01,  .734580E+01,  .136038E+02 / 
+      DATA cg_aer/.619800E+00,  .619800E+00,  .619800E+00,  
+     .            .619800E+00,  .619800E+00,  .662700E+00,  
+     .            .682100E+00,  .698500E+00,  .712500E+00,  
+     .            .721800E+00,  .734600E+00,  .755800E+00,  
+     .            .545600E+00,  .545600E+00,  .545600E+00,  
+     .            .545600E+00,  .545600E+00,  .583700E+00,  
+     .            .607100E+00,  .627700E+00,  .645800E+00,  
+     .            .658400E+00,  .676500E+00,  .708500E+00 / 
+      DATA alpha_aer_sulfate/
+     . 4.910,4.910,4.910,4.910,6.547,7.373,
+     . 8.373,9.788,12.167,14.256,17.924,28.433,
+     . 1.453,1.453,1.453,1.453,2.003,2.321,
+     . 2.711,3.282,4.287,5.210,6.914,12.305,
+     . 4.308,4.308,4.308,4.308,5.753,6.521,
+     . 7.449,8.772,11.014,12.999,16.518,26.772,
+     . 3.265,3.265,3.265,3.265,4.388,5.016,
+     . 5.775,6.868,8.745,10.429,13.457,22.538,
+     . 2.116,2.116,2.116,2.116,2.882,3.330,
+     . 3.876,4.670,6.059,7.327,9.650,16.883/
+c
+      DO i=1, klon
+         taue670(i)=0.0
+         taue865(i)=0.0
+      ENDDO
+c      
+      DO k=1, klev
+      DO i=1, klon
+         if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k)
+         if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k)         
+        zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+        zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG           ! m
+        rh=MIN(RHcl(i,k)*100.,RH_MAX)
+        RH_num = INT( rh/10. + 1.)
+        IF (rh.LT.0.) STOP 'aeropt: RH < 0 not possible'
+        IF (rh.gt.85.) RH_num=10
+        IF (rh.gt.90.) RH_num=11
+        DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+c                
+        inu=1
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+c
+        inu=2
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+cjq
+cjq for aerosol index
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,4) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,4)-
+     .       alpha_aer_sulfate(RH_num,4)) !--m2/g 
+c     
+        taue670(i)=taue670(i)+
+     .       alphasulfate*msulfate(i,k)*zdz*1.e-6
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,5) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,5)-
+     .       alpha_aer_sulfate(RH_num,5)) !--m2/g 
+c
+        taue865(i)=taue865(i)+
+     .         alphasulfate*msulfate(i,k)*zdz*1.e-6
+        
+      ENDDO
+      ENDDO
+c      
+      DO i=1, klon
+        ai(i)=(-log(MAX(taue670(i),0.0001)/
+     .                MAX(taue865(i),0.0001))/log(670./865.)) * 
+     .        taue865(i)
+      ENDDO     
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ajsec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ajsec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ajsec.F	(revision 984)
@@ -0,0 +1,249 @@
+!
+! $Header$
+!
+      SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+c
+      INTEGER limbas, limhau ! les couches a ajuster
+ccc      PARAMETER (limbas=klev-3, limhau=klev)
+cym      PARAMETER (limbas=1, limhau=klev)
+c
+      LOGICAL mixq
+ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+c
+      REAL zh(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+c
+c Initialisation:
+c
+cym
+      limbas=1
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c------------------------------------- detection des profils a modifier
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = limbas+1, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      IF (limbas.GT.1) THEN
+      DO k = 1, limbas-1
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (limhau.LT.klev) THEN
+      DO k = limhau+1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL d_t(klon,klev)
+c
+      REAL local_h(klon,klev)
+      REAL hm, sm
+      LOGICAL modif(klon), down
+      INTEGER i, l, l1, l2
+c------------------------------------- detection des profils a modifier
+      DO i = 1, klon
+         modif(i)   = .false.
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
+      ENDDO
+      ENDDO
+c
+      DO l = 2, klev
+      DO i = 1, klon
+         IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
+            modif(i) = .true.
+         ELSE
+            modif(i) = modif(i)
+         ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      do 1080 i = 1, klon
+        if (modif(i)) then
+          l2 = 1
+ 8000     continue
+            l2 = l2 + 1
+            if (l2 .gt. klev) goto 8001
+            if (local_h(i, l2) .lt. local_h(i, l2-1)) then
+              l1 = l2 - 1
+              l  = l1
+              sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1))
+              hm = local_h(i, l2)
+ 8020         continue
+                sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+                hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+     .                         * (local_h(i, l) - hm) / sm
+                down = .false.
+                if (l1 .ne. 1) then
+                  if (hm .lt. local_h(i, l1-1)) then
+                    down = .true.
+                  end if
+                end if
+                if (down) then
+                  l1 = l1 - 1
+                  l  = l1
+                else
+                  if ((l2 .eq. klev)) GOTO 8021
+                  IF ((local_h(i, l2+1).ge.hm)) goto 8021
+                  l2 = l2 + 1
+                  l  = l2
+                end if
+              go to 8020
+ 8021         continue
+c------------ nouveau profil : constant (valeur moyenne)
+              do 1100 l = l1, l2
+                local_h(i, l) = hm
+ 1100         continue
+              l2 = l2 + 1
+            end if
+          go to 8000
+ 8001     continue
+        end if
+ 1080 continue
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/albedo.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/albedo.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/albedo.F	(revision 984)
@@ -0,0 +1,191 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE alboc(rjour,rlat,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+c Date: le 16 mars 1995
+c Objet: Calculer l'albedo sur l'ocean
+c Methode: Integrer numeriquement l'albedo pendant une journee
+c
+c Arguments;
+c rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+c rlat (in,R)   : latitude en degre
+c albedo (out,R): albedo obtenu (de 0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "clesphys.h"
+c
+c fmagic -> clesphys.h/.inc
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7)
+      INTEGER npts ! il controle la precision de l'integration
+      PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+c
+      REAL rlat(klon), rjour, albedo(klon)
+      REAL zdist, zlonsun, zpi, zdeclin
+      REAL rmu,alb, srmu, salb, fauxo, aa, bb
+      INTEGER i, k
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      fauxo = (1.47-ACOS(rmu))/.15
+      alb = 0.03+0.630/(1.+fauxo*fauxo)
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         fauxo = (1.47-ACOS(rmu))/.15
+         alb = 0.03+0.630/(1.+fauxo*fauxo)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+  999 CONTINUE
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 1999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+cIM cf. PB  alb = 0.058/(rmu + 0.30)
+c     alb = 0.058/(rmu + 0.30) * 1.5
+      alb = 0.058/(rmu + 0.30) * 1.2
+c     alb = 0.058/(rmu + 0.30) * 1.3
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+cIM cf. PB      alb = 0.058/(rmu + 0.30)
+c        alb = 0.058/(rmu + 0.30) * 1.5
+         alb = 0.058/(rmu + 0.30) * 1.2
+c        alb = 0.058/(rmu + 0.30) * 1.3
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+1999  CONTINUE
+      ENDIF
+      RETURN
+      END
+c=====================================================================
+      SUBROUTINE alboc_cd(rmu0,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940624
+c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+c Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+C on radiation in the atmosphere, 19-28 August 1976, science Press,
+C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+c
+c Arguments
+c rmu0    (in): cosinus de l'angle solaire zenithal
+c albedo (out): albedo de surface de l'ocean
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+      REAL rmu0(klon), albedo(klon)
+c
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7) 
+c
+      REAL fauxo
+      INTEGER i
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      DO i = 1, klon
+c
+         rmu0(i) = MAX(rmu0(i),0.0)
+c
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      DO i = 1, klon
+         rmu0(i) = MAX(rmu0(i),0.0)
+cIM:orig albedo(i) = 0.058/(rmu0(i) + 0.30)
+         albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+      ENDIF
+c
+      RETURN
+      END
+c========================================================================
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/albsno.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/albsno.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/albsno.F90	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
+
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN)                  :: klon, knon
+  REAL, INTENT(IN)                     :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+
+! In/Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
+
+! Local variables
+!****************************************************************************************
+  INTEGER                              :: i, nv
+  INTEGER, PARAMETER                   :: nvm = 8 
+  REAL                                 :: as
+  REAL, DIMENSION(klon,nvm)            :: veget
+  REAL, DIMENSION(nvm),SAVE            :: init, decay
+  !$OMP THREADPRIVATE(init, decay)
+
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+!****************************************************************************************
+
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+     alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+     DO i = 1, knon
+        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+     ENDDO
+  ENDDO
+  
+
+! modilation en fonction de l'age de la neige
+  DO i = 1, knon
+     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+     agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+  
+END SUBROUTINE albsno
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/atm2geo.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/atm2geo.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/atm2geo.F	(revision 984)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+C
+      SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
+      USE dimphy
+      USE mod_phys_lmdz_para
+      IMPLICIT NONE
+      include 'dimensions.h'
+cc
+cc Change wind local atmospheric coordinates to
+cc geocentric
+cc
+cxxx      INCLUDE 'param.h'
+c
+      INTEGER, INTENT (in)              :: im, jm
+      REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn
+      REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
+      REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz
+c
+      REAL, PARAMETER :: rpi = 3.141592653E0
+      REAL, PARAMETER :: rad = rpi / 180.0E0
+c
+      REAL, DIMENSION (im,jm) :: zsinlon, zcoslon
+      REAL, DIMENSION (im,jm) :: zsinlat, zcoslat
+c
+      LOGICAL, SAVE :: linit = .FALSE.
+c$OMP THREADPRIVATE(linit)
+
+cym utilise pour le couple, ne fonctionne que en MPI seul
+c
+cxxx      IF ( .NOT. linit ) THEN 
+          zsinlon = SIN (rad * plon)
+          zcoslon = COS (rad * plon)
+          zsinlat = SIN (rad * plat)
+          zcoslat = COS (rad * plat)
+          linit = .TRUE.
+cxxx      ENDIF 
+c
+      pxx = - zsinlon * pte - zsinlat * zcoslon * ptn
+      pyy =   zcoslon * pte - zsinlat * zsinlon * ptn
+      pzz =   zcoslat * ptn
+
+c
+c Value at North Pole
+      IF (is_north_pole) THEN
+        pxx ( :,  1) = - ptn ( 1, 1)
+        pyy ( :,  1) = - pte ( 1, 1)
+        pzz ( :,  1) = 0.0
+      ENDIF
+c Value at South Pole
+      
+      IF (is_south_pole) THEN
+        pxx ( :, jm) = + ptn ( 1, jm)
+        pyy ( :, jm) = + pte ( 1, jm)
+        pzz ( :, jm) = 0.0
+      ENDIF
+ 
+      RETURN 
+      END SUBROUTINE atm2geo
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calbeta.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calbeta.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calbeta.F90	(revision 984)
@@ -0,0 +1,103 @@
+!
+! $Header$
+!
+SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
+     vbeta,vcal,vdif)
+
+  USE dimphy
+  IMPLICIT none
+!======================================================================
+! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
+! date: 19940414
+!======================================================================
+!
+! Calculer quelques parametres pour appliquer la couche limite
+! ------------------------------------------------------------
+  INCLUDE "indicesol.h"
+  
+! Variables d'entrees
+!****************************************************************************************
+  REAL, INTENT(IN)                   :: dtime
+  INTEGER, INTENT(IN)                :: indice
+  INTEGER, INTENT(IN)                :: knon
+  REAL, DIMENSION(klon), INTENT(IN)  :: snow
+  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
+
+  
+! Variables de sorties
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
+  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
+  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
+
+! Variables locales
+!****************************************************************************************
+  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
+!cc      PARAMETER (tau_gl=86400.0*30.0)
+  REAL, PARAMETER :: mx_eau_sol=150.0
+  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
+  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
+  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
+  
+  INTEGER         :: i
+
+!****************************************************************************************  
+   
+  vbeta(:) = 0.0
+  vcal(:) = 0.0
+  vdif(:) = 0.0
+  
+  IF (indice.EQ.is_oce) THEN
+     DO i = 1, knon
+        vcal(i)   = 0.0
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_sic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 1.0/tau_gl
+!          vdif(i) = calice/tau_gl ! c'etait une erreur
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_ter) THEN
+     DO i = 1, knon
+        vcal(i) = calsol
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_lic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+END SUBROUTINE calbeta
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcratqs.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcratqs.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcratqs.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE calcratqs ( flag_ratqs,
+     I            paprs,pplay,q_seri,d_t_con,d_t_ajs
+     O           ,ratqs,zpt_conv)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL d_t_con(klon,klev)
+      REAL d_t_ajs(klon,klev)
+      REAL ratqs(klon,klev)
+      LOGICAL pt_conv(klon,klev)
+      REAL q_seri(klon,klev)
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+c$OMP THREADPRIVATE(firstcall)
+
+      REAL ratqsmin,ratqsmax,zx,epmax
+      REAL ratqs1,ratqs2,ratqs3,ratqs4
+      REAL ratqsc1,ratqsc2,ratqsc3,ratqsc4
+      INTEGER i,k
+      INTEGER flag_ratqs
+      save ratqsmin,ratqsmax,epmax
+      save ratqs1,ratqs2,ratqs3,ratqs4
+      save ratqsc1,ratqsc2,ratqsc3,ratqsc4
+c$OMP THREADPRIVATE(ratqsmin,ratqsmax,epmax)
+c$OMP THREADPRIVATE(ratqs1,ratqs2,ratqs3,ratqs4)
+c$OMP THREADPRIVATE(ratqsc1,ratqsc2,ratqsc3,ratqsc4)
+      real zpt_conv(klon,klev)
+
+      REAL zx_min
+      PARAMETER (zx_min=1.0)
+      REAL zx_max
+      PARAMETER (zx_max=0.1)
+
+	zpt_conv=0.
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c
+      if (flag_ratqs.eq.0) then
+
+         ratqsmax=0.01
+         ratqsmin=0.3
+
+         if (firstcall) print*,'RATQS ANCIEN '
+         do k=1,klev
+         do i=1,klon
+            zx = pplay(i,k)/paprs(i,1)
+            zx = (zx_max-zx)/(zx_max-zx_min)
+            zx = MIN(MAX(zx,0.0),1.0)
+            zx = zx * zx * zx
+            ratqs(i,k)= zx * (ratqsmax-ratqsmin) + ratqsmin
+         enddo
+         enddo
+
+      else
+
+c  On aplique un ratqs "interactif" a toutes les mailles affectees
+c  par la convection ou se trouvant "sous" une maille affectee.
+         do i=1,klon
+            pt_conv(i,klev)=.false.
+         enddo
+         do k=klev-1,1,-1
+            do i=1,klon
+               pt_conv(i,k)=pt_conv(i,k+1).or.
+     s               (abs(d_t_con(i,k))+abs(d_t_ajs(i,k))).gt.1.e-8
+               if(pt_conv(i,k)) then
+                  zpt_conv(i,k)=1.
+               else
+                  zpt_conv(i,k)=0.
+               endif
+            enddo
+         enddo
+
+         if (flag_ratqs.eq.1) then
+
+            ratqsmin=0.4
+            ratqsmax=0.99
+            if (firstcall) print*,'RATQS INTERACTIF '
+            do k=1,klev
+                do i=1,klon
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=0.01
+     s                +1.5*0.25*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                      ratqs(i,k)=max(ratqs(i,k),0.1)
+                   else
+                      ratqs(i,k)=0.01+(ratqsmin-0.01)*
+     s             min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.)
+                   endif
+                enddo
+            enddo
+         else if (flag_ratqs.eq.2) then
+            do k=1,klev
+                do i=1,klon
+                   ratqs(i,k)=0.001+
+     s             (q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                   else
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmin)
+                   endif
+                enddo
+            enddo
+         else
+            do k=1,klev
+               do i=1,klon
+                  if (pplay(i,k).ge.95000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc1
+                     else
+                        ratqs(i,k)=ratqs1
+                     endif
+                  else if (pplay(i,k).ge.75000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc2
+                     else
+                        ratqs(i,k)=ratqs2
+                     endif
+                  else if (pplay(i,k).ge.50000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc3
+                     else
+                        ratqs(i,k)=ratqs3
+                     endif
+                  else
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc4
+                     else
+                        ratqs(i,k)=ratqs4
+                     endif
+                  endif
+               enddo
+            enddo
+         endif
+
+      endif
+
+      firstcall=.false.
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_REGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_REGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_REGDYN.h	(revision 984)
@@ -0,0 +1,22 @@
+c
+c $Header$
+c
+c calculs statistiques distribution nuage ftion du regime dynamique 
+c
+c Ce calcul doit etre fait a partir de valeurs mensuelles ??
+      CALL histo_o500_pctau(nbregdyn,pct_ocean,o500,fq_isccp,
+     &histoW,nhistoW)
+c
+c nhistoWt = somme de toutes les nhistoW
+      DO nreg=1, nbregdyn
+       DO k = 1, kmaxm1
+        DO l = 1, lmaxm1
+         DO iw = 1, iwmax
+          nhistoWt(k,l,iw,nreg)=nhistoWt(k,l,iw,nreg)+
+     &    nhistoW(k,l,iw,nreg)
+         ENDDO
+        ENDDO
+       ENDDO
+      ENDDO
+c
+cIM 190504 END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_STDlev.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_STDlev.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_STDlev.h	(revision 984)
@@ -0,0 +1,324 @@
+c
+c $Header$
+c
+c
+cIM on initialise les champs en debut du jour ou du mois 
+c
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,tsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,usumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,phisumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,qsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,rhsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,uvsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vqsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vTsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wqsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vphisumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wTsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,u2sumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,v2sumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,T2sumSTD)
+c
+cIM on interpole sur les niveaux STD de pression a chaque pas de temps de la physique
+c
+       DO k=1, nlevSTD
+c
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .              t_seri,tlevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             u_seri,ulevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             v_seri,vlevSTD(:,k))
+c
+        DO l=1, klev
+        DO i=1, klon
+         zx_tmp_fi3d(i,l)=paprs(i,l)
+        ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,zx_tmp_fi3d,rlevSTD(k),
+     .             omega,wlevSTD(:,k))
+c
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zphi/RG,philevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             qx(:,:,ivap),qlevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_rh*100.,rhlevSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,uvSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*q_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vqSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vTSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*qx(i,l,ivap)
+         ENDDO !i 
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,wqSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*zphi(i,l)/RG
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vphiSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,wTSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*u_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,u2STD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,v2STD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=t_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,T2STD(:,k))
+c
+       ENDDO !k=1,nlevSTD
+c
+cIM on somme les valeurs definies a chaque pas de temps de la physique ou 
+cIM toutes les 6 heures
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.TRUE.
+       CALL undefSTD(nlevSTD,itap,tlevSTD,
+     $               dtime,ecrit_hf,
+     $               oknondef,tnondef,tsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,ulevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,usumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,philevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,phisumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,qlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,qsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,rhlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,rhsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,uvSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,uvsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vqSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vqsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vTSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vTsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wqSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wqsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vphiSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vphisumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wTSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wTsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,u2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,u2sumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,v2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,v2sumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,T2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,T2sumSTD)
+c
+cIM on moyenne a la fin du jour ou du mois 
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,tsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,usumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,phisumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,qsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,rhsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,uvsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vqsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vTsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wqsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vphisumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wTsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,u2sumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,v2sumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,T2sumSTD)
+c
+cIM interpolation a chaque pas de temps du SWup(clr) et SWdn(clr) a 200 hPa
+c
+      CALL plevel(klon,klevp1,.true.,paprs,20000.,
+     $     swdn0,SWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swdn,SWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swup0,SWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swup,SWup200)
+c
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwdn0,LWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwdn,LWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwup0,LWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwup,LWup200)
+c
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_divers.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_divers.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_divers.h	(revision 984)
@@ -0,0 +1,29 @@
+c
+c $Header$
+c
+c
+c initialisations diverses au "debut" du mois
+c
+      IF(MOD(itap,INT(ecrit_mth)).EQ.1) THEN
+         DO i=1, klon
+          nday_rain(i)=0.
+         ENDDO !i
+c
+c surface terre
+       DO i=1, klon
+         IF(pctsrf_new(i,is_ter).GT.0.) THEN
+            paire_ter(i)=airephy(i)*pctsrf_new(i,is_ter)
+         ENDIF 
+       ENDDO
+c
+      ENDIF !MOD(itap,INT(ecrit_mth)).EQ.1
+c
+      IF(MOD(itap,INT(ecrit_day)).EQ.0) THEN
+c
+cIM calcul total_rain, nday_rain
+c
+       DO i = 1, klon
+        total_rain(i)=rain_fall(i)+snow_fall(i)  
+        IF(total_rain(i).GT.0.) nday_rain(i)=nday_rain(i)+1.
+       ENDDO
+      ENDIF !itap.EQ.ecrit_mth
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_fluxs_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_fluxs_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_fluxs_mod.F90	(revision 984)
@@ -0,0 +1,246 @@
+!
+! $Header$
+!
+MODULE calcul_fluxs_mod
+
+
+CONTAINS
+  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
+       tsurf, p1lay, cal, beta, coef1lay, ps, &
+       precip_rain, precip_snow, snow, qsurf, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    USE dimphy, ONLY : klon
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   qsurf        humidite de l'air au dessus du sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon, nisurf
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
+    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
+
+! Parametres entree-sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
+
+! Parametres sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
+
+! Variables locales
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
+    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
+    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+    REAL, DIMENSION(klon)                :: zx_sl, zx_k1
+    REAL, DIMENSION(klon)                :: d_ts
+    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+    REAL                                 :: qsat_new, q1_new
+    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
+    REAL, PARAMETER                      :: max_eau_sol = 150.0
+    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
+    LOGICAL                              :: fonte_neige
+    LOGICAL, SAVE                        :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! End definition
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
+    
+    IF (check) THEN
+       WRITE(*,*)' radsol (min, max)', &
+            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
+       CALL flush(6)
+    ENDIF
+  
+! Traitement neige et humidite du sol
+!****************************************************************************************
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!****************************************************************************************
+    evap = 0.
+    fluxsens=0.
+    fluxlat=0.
+    dflux_s = 0.
+    dflux_l = 0.	
+!
+! zx_qs = qsat en kg/kg
+!****************************************************************************************
+    DO i = 1, knon
+       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+       IF (thermcep) THEN
+          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+          zx_qs=MIN(0.5,zx_qs)
+          zcor=1./(1.-retv*zx_qs)
+          zx_qs=zx_qs*zcor
+          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+               /RLVTT / zx_pkh(i)
+       ELSE
+          IF (tsurf(i).LT.t_coup) THEN
+             zx_qs = qsats(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ELSE
+             zx_qs = qsatl(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ENDIF
+       ENDIF
+       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+       zx_qsat(i) = zx_qs
+       zx_coef(i) = coef1lay(i) * &
+            (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
+            p1lay(i)/(RD*t1lay(i))
+       
+    ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!****************************************************************************************
+
+    DO i = 1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+       zx_k1(i) = zx_coef(i)
+    ENDDO
+    
+
+    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)
+       zx_nq(i) = beta(i) * zx_k1(i) * (-1. * 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)
+     
+! Tsurface
+       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+            + dif_grnd(i) * t_grnd * dtime)/ &
+            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+            + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+       d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+       fluxlat(i) = - evap(i) * zx_sl(i)
+       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+       
+! Derives des flux dF/dTs (W m-2 K-1):
+       dflux_s(i) = zx_nh(i)
+       dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+! Nouvelle valeure de l'humidite au dessus du sol
+       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
+       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+    ENDDO
+!
+!****************************************************************************************
+!
+  END SUBROUTINE calcul_fluxs
+
+END MODULE calcul_fluxs_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_simulISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_simulISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calcul_simulISCCP.h	(revision 984)
@@ -0,0 +1,168 @@
+c
+c $Header$
+c
+c on appelle le simulateur ISCCP toutes les 3h
+c et on fait des sorties 1 fois par jour 
+c
+c ATTENTION : le temps de calcul peut augmenter considerablement !
+c =============================================================== c
+      DO n=1, napisccp
+c
+      nbapp_isccp=30 !appel toutes les 15h
+cIM 170107      isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique
+      freqin_pdt(n)=ifreq_isccp(n)
+c
+cIM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee
+c
+      DO i=1, klon
+       sunlit(i)=1 
+       IF(rmu0(i).EQ.0.) sunlit(i)=0
+       nbsunlit(1,i,n)=FLOAT(sunlit(i))
+      ENDDO
+c
+cIM calcul tau, emissivite nuages convectifs
+c
+      convfra(:,:)=rnebcon(:,:)
+      convliq(:,:)=rnebcon(:,:)*clwcon(:,:)
+c
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, convliq, convfra, dtau_c, dem_c,
+     .            cldh_c, cldl_c, cldm_c, cldt_c, cldq_c,
+     .            flwp_c, fiwp_c, flwc_c, fiwc_c,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+c
+cIM calcul tau, emissivite nuages startiformes
+c
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, dtau_s, dem_s,
+     .            cldh_s, cldl_s, cldm_s, cldt_s, cldq_s,
+     .            flwp_s, fiwp_s, flwc_s, fiwc_s,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+c
+      cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+c
+cIM inversion des niveaux de pression ==> de haut en bas
+c
+      CALL haut2bas(klon, klev, pplay, pfull)
+      CALL haut2bas(klon, klev, q_seri, qv)
+      CALL haut2bas(klon, klev, cldtot, cc)
+      CALL haut2bas(klon, klev, rnebcon, conv)
+      CALL haut2bas(klon, klev, dtau_s, dtau_sH2B)
+      CALL haut2bas(klon, klev, dtau_c, dtau_cH2B)
+      CALL haut2bas(klon, klev, t_seri, at)
+      CALL haut2bas(klon, klev, dem_s, dem_sH2B)
+      CALL haut2bas(klon, klev, dem_c, dem_cH2B)
+      CALL haut2bas(klon, klevp1, paprs, phalf)
+c
+cIM lecture invtau, tautab des fichiers formattes
+c
+      IF (debut) THEN
+c$OMP MASTER
+c     open(99,file='tautab.bin',access='sequential',
+c    $     form='unformatted',status='old')
+c     read(99) tautab_omp
+c
+      open(99,file='tautab.formatted', FORM='FORMATTED')
+      read(99,'(f30.20)') tautab_omp
+      close(99)
+c
+      open(99,file='invtau.formatted',form='FORMATTED')
+      read(99,'(i10)') invtau_omp
+      close(99)
+c$OMP END MASTER
+c$OMP BARRIER
+      tautab=tautab_omp
+      invtau=invtau_omp
+c
+      ENDIF !debut
+c
+cIM: initialisation de seed
+c
+        DO i=1, klon
+c
+         aa=ABS(paprs(i,2)-NINT(paprs(i,2)))
+         seed_re(i,n)=1000.*aa+1.
+         seed(i,n)=NINT(seed_re(i,n))
+c
+         IF(seed(i,n).LT.50) THEN
+c          print*,'seed<50 avant i seed itap paprs',i,
+c    .     seed(i,n),itap,paprs(i,2)
+           seed(i,n)=50+seed(i,n)+i+itap
+           seed_old(i,n)=seed(i,n)
+c
+           IF(itap.GT.1) then
+            IF(seed(i,n).EQ.seed_old(i,n)) THEN
+             seed(i,n)=seed(i,n)+10
+             seed_old(i,n)=seed(i,n)
+            ENDIF
+           ENDIF
+c
+c          print*,'seed<50 apres i seed itap paprs',i,
+c    .     seed(i,n),itap,paprs(i,2)
+c
+          ELSE IF(seed(i,n).EQ.0) THEN
+           print*,'seed=0 i paprs aa seed_re',
+     .     i,paprs(i,2),aa,seed_re(i,n)
+           STOP
+          ELSE IF(seed(i,n).LT.0) THEN
+           print*,'seed < 0, i seed itap paprs',i,
+     .     seed(i,n),itap,paprs(i,2)
+           STOP
+          ENDIF
+c
+        ENDDO
+c     
+cIM: pas de debug, debugcol
+      debug=0
+      debugcol=0
+c
+cIM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa)
+c
+        DO k=1, klevm1
+        kp1=k+1
+c       PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1)
+        if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN
+         DO i=1, klon
+          o500(i)=omega(i,k)*RDAY/100.
+c         if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1)
+         ENDDO
+         GOTO 1000
+        endif 
+1000  continue
+      ENDDO
+c
+cIM recalcule les nuages vus par satellite, via le simulateur ISCCP
+c
+      CALL ISCCP_CLOUD_TYPES(
+     &     debug,
+     &     debugcol,
+     &     klon,
+     &     sunlit,
+     &     klev,
+     &     ncol(n),
+     &     seed(:,n),
+     &     pfull,
+     &     phalf,
+     &     qv, cc, conv, dtau_sH2B, dtau_cH2B,
+     &     top_height,
+     &     overlap,
+     &     tautab,
+     &     invtau,
+     &     ztsol,
+     &     emsfc_lw,
+     &     at, dem_sH2B, dem_cH2B,
+     &     fq_isccp(:,:,:,n),
+     &     totalcldarea(:,n),
+     &     meanptop(:,n),
+     &     meantaucld(:,n),
+     &     boxtau(:,:,n),
+     &     boxptop(:,:,n))
+c
+      ENDDO !n=1, napisccp
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calltherm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calltherm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/calltherm.F	(revision 984)
@@ -0,0 +1,136 @@
+!
+! $Header$
+!
+      subroutine calltherm(dtime
+     s      ,pplay,paprs,pphi
+     s      ,u_seri,v_seri,t_seri,q_seri
+     s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
+     s      ,fm_therm,entr_therm)
+
+      USE dimphy
+      implicit none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "thermcell.h"
+
+c  A inclure eventuellement dans les fichiers de configuration
+      data r_aspect_thermals,l_mix_thermals,tho_thermals/4.,10.,0./
+      data w2di_thermals/0/
+
+      REAL dtime
+
+      REAL u_seri(klon,klev),v_seri(klon,klev)
+      REAL t_seri(klon,klev),q_seri(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+
+CFH Update Thermiques
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_u_ajs(klon,klev),d_v_ajs(klon,klev)
+      real fm_therm(klon,klev+1),entr_therm(klon,klev)
+
+
+c variables locales
+      REAL d_t_the(klon,klev), d_q_the(klon,klev)
+      REAL d_u_the(klon,klev),d_v_the(klon,klev)
+c
+cym      real zfm_therm(klon,klev+1),zentr_therm(klon,klev),zdt
+cym      save zentr_therm,zfm_therm
+      real,allocatable,dimension(:,:),save :: zfm_therm,zentr_therm
+c$OMP THREADPRIVATE(zfm_therm,zentr_therm)
+      real :: zdt
+      logical,save :: first=.true.
+c$OMP THREADPRIVATE(first)
+      integer i,k
+
+*********************************************************
+
+c  Modele du thermique
+c  ===================
+c         print*,'thermiques: WARNING on passe t au lieu de t_seri'
+       print*,'avant isplit ',nsplit_thermals
+
+cym initialisation dynamique
+         if (first) then
+	   allocate(zfm_therm(klon,klev+1),zentr_therm(klon,klev))
+	   zfm_therm(:,:)=0.
+	   zentr_therm(:,:)=0.
+	   first=.false.
+	 endif
+	 
+         fm_therm(:,:)=0.
+         entr_therm(:,:)=0.
+
+c   tests sur les valeurs negatives de l'eau
+         do k=1,klev
+            do i=1,klon
+               if (.not.q_seri(i,k).ge.0.) then
+                   print*,'WARN eau<0 avant therm i=',i,'  k=',k
+     s         ,' dq,q',d_q_the(i,k),q_seri(i,k)
+                  q_seri(i,k)=1.e-15
+               endif
+            enddo
+         enddo
+
+
+         zdt=dtime/float(nsplit_thermals)
+         do isplit=1,nsplit_thermals
+
+cym            CALL thermcell(klon,klev,zdt
+cym     s      ,pplay,paprs,pphi
+cym     s      ,u_seri,v_seri,t_seri,q_seri
+cym     s      ,d_u_the,d_v_the,d_t_the,d_q_the
+cym     s      ,zfm_therm,zentr_therm
+cym     s      ,r_aspect_thermals,l_mix_thermals,w2di_thermals
+cym     s      ,tho_thermals,3)
+
+            CALL thermcell(klon,klev,zdt
+     s      ,pplay,paprs,pphi
+     s      ,u_seri,v_seri,t_seri,q_seri
+     s      ,d_u_the,d_v_the,d_t_the,d_q_the
+     s      ,zfm_therm,zentr_therm
+     s      ,r_aspect_thermals,l_mix_thermals,w2di_thermals
+     s      ,tho_thermals)
+
+c  transformation de la derivee en tendance
+            d_t_the(:,:)=d_t_the(:,:)*dtime/float(nsplit_thermals)
+            d_u_the(:,:)=d_u_the(:,:)*dtime/float(nsplit_thermals)
+            d_v_the(:,:)=d_v_the(:,:)*dtime/float(nsplit_thermals)
+            d_q_the(:,:)=d_q_the(:,:)*dtime/float(nsplit_thermals)
+            fm_therm(:,:)=fm_therm(:,:)
+     s      +zfm_therm(:,:)/float(nsplit_thermals)
+            entr_therm(:,:)=entr_therm(:,:)
+     s       +zentr_therm(:,:)/float(nsplit_thermals)
+            fm_therm(:,klev+1)=0.
+
+
+
+c  accumulation de la tendance
+            d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_the(:,:)
+            d_u_ajs(:,:)=d_u_ajs(:,:)+d_u_the(:,:)
+            d_v_ajs(:,:)=d_v_ajs(:,:)+d_v_the(:,:)
+            d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_the(:,:)
+
+c  incrementation des variables meteo
+            t_seri(:,:) = t_seri(:,:) + d_t_the(:,:)
+            u_seri(:,:) = u_seri(:,:) + d_u_the(:,:)
+            v_seri(:,:) = v_seri(:,:) + d_v_the(:,:)
+            q_seri(:,:) = q_seri(:,:) + d_q_the(:,:)
+
+c   tests sur les valeurs negatives de l'eau
+            DO k = 1, klev
+            DO i = 1, klon
+               if (.not.q_seri(i,k).ge.0.) then
+                   print*,'WARN eau<0 apres therm i=',i,'  k=',k
+     s         ,' dq,q',d_q_the(i,k),q_seri(i,k)
+                  q_seri(i,k)=1.e-15
+               endif
+            ENDDO
+            ENDDO
+
+         enddo ! isplit
+
+      return
+
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/chem.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/chem.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/chem.h	(revision 984)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+      INTEGER idms, iso2, iso4, ih2s, idmso, imsa, ih2o2
+      PARAMETER (idms=1, iso2=2, iso4=3)
+      PARAMETER (ih2s=4, idmso=5, imsa=6, ih2o2=7)
+
+      REAL n_avogadro, masse_s, masse_so4, rho_water, rho_ice
+      PARAMETER (n_avogadro=6.02E23)                  !--molec mol-1
+      PARAMETER (masse_s=32.0)                        !--g mol-1
+      PARAMETER (masse_so4=96.0)                      !--g mol-1
+      PARAMETER (rho_water=1000.0)                    !--kg m-3
+      PARAMETER (rho_ice=500.0)                       !--kg m-3
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clcdrag.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clcdrag.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clcdrag.F90	(revision 984)
@@ -0,0 +1,108 @@
+!
+! $Header$
+!
+      SUBROUTINE clcdrag(klon, knon, nsrf, zxli, &
+                         u, v, t, q, zgeop, &
+                         ts, qsurf, rugos, &
+                         pcfm, pcfh)
+      IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh).   
+!
+! ================================================================= c
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- calcul des cdrags selon Laurent Li
+! u-------input-R- vent zonal au 1er niveau du modele
+! v-------input-R- vent meridien au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+!
+! pcfm---output-R- cdrag pour le moment 
+! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, intent(in), dimension(klon) :: u, v, t, q, zgeop
+      REAL, intent(in), dimension(klon) :: ts, qsurf
+      REAL, intent(in), dimension(klon) :: rugos
+      REAL, intent(out), dimension(klon) :: pcfm, pcfh
+! ================================================================= c
+!
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "indicesol.h"
+!
+! Quelques constantes et options:
+!!$PB      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+      REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+      INTEGER :: i
+      REAL :: zdu2, ztsolv, ztvd, zscf
+      REAL :: zucf, zcr
+      REAL :: friv, frih
+      REAL, dimension(klon) :: zcfm1, zcfm2
+      REAL, dimension(klon) :: zcfh1, zcfh2
+      REAL, dimension(klon) :: zcdn
+      REAL, dimension(klon) :: zri
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+! ================================================================= c
+!
+! Calculer le frottement au sol (Cdrag)
+!
+      DO i = 1, knon
+        zdu2 = max(cepdu2,u(i)**2+v(i)**2)
+        ztsolv = ts(i) * (1.0+RETV*qsurf(i))
+        ztvd = (t(i)+zgeop(i)/RCPD/(1.+RVTMP2*q(i))) &
+             *(1.+RETV*q(i))
+        zri(i) = zgeop(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+        zcdn(i) = (ckap/log(1.+zgeop(i)/(RG*rugos(i))))**2
+!
+!!$        IF (zri(i) .ge. 0.) THEN      ! situation stable
+        IF (zri(i) .gt. 0.) THEN      ! situation stable
+          zri(i) = min(20.,zri(i))
+          IF (.NOT.zxli) THEN
+            zscf = SQRT(1.+cd*ABS(zri(i)))
+            FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1)
+            zcfm1(i) = zcdn(i) * FRIV
+            FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 )
+!!$  PB          zcfh1(i) = zcdn(i) * FRIH
+            zcfh1(i) = 0.8 * zcdn(i) * FRIH
+            pcfm(i) = zcfm1(i)
+            pcfh(i) = zcfh1(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fsta(zri(i))
+            pcfh(i) = zcdn(i)* fsta(zri(i))
+          ENDIF
+        ELSE                          ! situation instable
+          IF (.NOT.zxli) THEN
+            zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
+                 *(1.0+zgeop(i)/(RG*rugos(i)))))
+            zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1)
+!!$PB            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            zcfh2(i) = 0.8 * zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            pcfm(i) = zcfm2(i)
+            pcfh(i) = zcfh2(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fins(zri(i))
+            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) =0.8* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
+        ENDIF
+      END DO
+      RETURN
+      END SUBROUTINE clcdrag
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clesphys.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clesphys.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clesphys.h	(revision 984)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!..include cles_phys.h
+!
+       LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf 
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
+       REAL co2_ppm, solaire
+       REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12  
+       REAL*8 CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt
+
+!OM ---> correction du bilan d'eau global
+!OM Correction sur precip KE
+       REAL cvl_corr
+!OM Fonte calotte dans bilan eau
+       LOGICAL ok_lic_melt
+
+!IM simulateur ISCCP 
+       INTEGER top_height, overlap
+!IM seuils cdrm, cdrh
+       REAL cdmmax, cdhmax
+!IM param. stabilite s/ terres et en dehors
+       REAL ksta, ksta_ter
+!IM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH
+       LOGICAL ok_kzmin
+!IM fmagic : parametre pour regler l albedo sur ocean
+       REAL fmagic
+!IM lev_histhf  : niveau sorties 6h
+!IM lev_histday : niveau sorties journalieres
+!IM lev_histmth : niveau sorties mensuelles
+       INTEGER lev_histhf, lev_histday, lev_histmth
+       CHARACTER*4 type_run
+       LOGICAL ok_isccp, ok_regdyn
+       REAL lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+       REAL ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day
+       REAL ecrit_mth, ecrit_tra, ecrit_reg 
+       REAL freq_ISCCP, ecrit_ISCCP
+       INTEGER :: ip_ebil_phy
+       LOGICAL ok_slab_sicOBS
+
+       COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
+     &     ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con       &
+     &     , co2_ppm, solaire, RCO2, RCH4, RN2O, RCFC11, RCFC12         &
+     &     , CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt                     &
+     &     , top_height, overlap, cdmmax, cdhmax, ksta, ksta_ter        &
+     &     , ok_kzmin, fmagic, lev_histhf, lev_histday, lev_histmth     &
+     &     , type_run, ok_isccp, ok_regdyn                              &
+     &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
+     &     , ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day               &
+     &     , ecrit_mth, ecrit_tra, ecrit_reg                            &
+     &     , freq_ISCCP, ecrit_ISCCP, ip_ebil_phy                       &
+     &     , ok_slab_sicOBS, ok_lic_melt, cvl_corr
+     
+!$OMP THREADPRIVATE(/clesphys/)
+ 
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clift.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clift.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clift.F	(revision 984)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+        SUBROUTINE CLIFT (P,T,RR,RS,PLCL,DPLCLDT,DPLCLDQ)
+C***************************************************************
+C*                                                             *
+C* CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
+C*         DERIVATIVES RELATIVE TO T AND R                     *
+C*   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
+C*                                                             *
+C* written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
+C* modified by :                                               *
+C***************************************************************
+C*
+C*Arguments :
+C*
+C* Input :  P = pressure of level from wich lifting is performed
+C*          T = temperature of level P
+C*          RR = vapour mixing ratio at level P
+C*          RS = vapour saturation mixing ratio at level P
+C*
+C* Output : PLCL = lifting condensation level
+C*          DPLCLDT = derivative of PLCL relative to T
+C*          DPLCLDQ = derivative of PLCL relative to R
+C*
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c      CPD = 3.5 * RD
+c      CPV = 4.0 * RV
+c      CL = 4218.0
+c      CI=2090.0
+c      CPVMCL=CL-CPV
+c      CLMCI=CL-CI
+c      EPS=RD/RV
+c      ALV0=2.5008E+06
+c      ALF0=3.34E+05
+c
+c on utilise les constantes thermo du Centre Europeen: (sb)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+c
+c      Bolton formula coefficients :
+      A = 1669.0
+      B = 122.0
+c
+      RH=RR/RS
+      CHI=T/(A-B*RH-T)
+      PLCL=P*(RH**CHI)
+c
+      ALV = ALV0 - CPVMCL*(T-273.15)
+c
+c -- sb: correction:
+c       DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
+      DPLCLDQ = PLCL*CHI*( 1./RR + B*CHI/T/RS*ALOG(RH) )
+c sb --
+c
+      DPLCLDT = PLCL*CHI*((A-B*RH*(1.+ALV/RV/T))/T**2*CHI*ALOG(RH)
+     $                    - ALV/RV/T**2 )
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/climb_hq_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/climb_hq_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/climb_hq_mod.F90	(revision 984)
@@ -0,0 +1,366 @@
+MODULE climb_hq_mod
+!
+! Module to solve the verctical diffusion of "q" and "H"; 
+! specific humidity and potential energi.
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_hq_down, climb_hq_up
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
+  !$OMP THREADPRIVATE(gamaq,gamah)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
+  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
+  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
+  !$OMP THREADPRIVATE(Kcoefhq)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
+       delp, temp, q, dtime, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+    INCLUDE "YOMCST.h"
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petBcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqBcoef
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: dels, local_H
+    REAL, DIMENSION(klon)                    :: psref, delz, pkh
+    INTEGER                                  :: k, i, ierr
+
+! Include
+!****************************************************************************************
+  INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation
+!   
+!****************************************************************************************
+
+    ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
+    
+    ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
+    
+    ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
+    
+    ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
+    
+    ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
+    
+    ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
+    
+    ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
+       
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefhq(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefhq(i,k) = &
+               coefhq(i,k)*RG /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefhq(i,k) = Kcoefhq(i,k) * dtime*RG
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of start value for gama
+    IF (iflag_pbl == 1) THEN
+       gamaq(:,:) = 0.0
+       gamah(:,:) = -1.0e-03
+       gamah(:,2) = -2.5e-03
+    ELSE
+       gamaq(:,:) = 0.0
+       gamah(:,:) = 0.0
+    ENDIF
+    
+!   calculation of gama
+    DO k = 2, klev
+       DO i = 1, knon
+          delz(i)  = RD * (temp(i,k-1)+temp(i,k)) / & 
+               2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+          pkh(i) = (psref(i)/paprs(i,k))**RKAPPA
+          
+          gamaq(i,k) = gamaq(i,k) * delz(i)    
+          gamah(i,k) = gamah(i,k) * delz(i) * RCPD * pkh(i)
+       ENDDO
+    ENDDO
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific humidity, q
+!
+!****************************************************************************************
+    dels(:,:) = delp(:,:)
+    
+    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), dels(:,:), q(:,:), &
+         Ccoef_Q(:,:), Dcoef_Q(:,:))
+
+!****************************************************************************************
+! 5)
+! Calculte the coefficients C and D for potentiel entalpie, H 
+!
+!****************************************************************************************
+    dels(:,:)    = 0.0
+    local_H(:,:) = 0.0
+
+    DO k=1,klev
+       DO i = 1, knon
+          dels(i,k) = (pplay(i,k)/psref(i))**RKAPPA * delp(i,k)               
+          local_H(i,k) = RCPD * temp(i,k) * &
+               (psref(i)/pplay(i,k))**RKAPPA
+       ENDDO
+    ENDDO
+
+
+    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), dels(:,:), local_H(:,:), &
+         Ccoef_H(:,:), Dcoef_H(:,:))
+ 
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    petAcoef(1:knon) = Ccoef_H(1:knon,1)
+    peqAcoef(1:knon) = Ccoef_Q(1:knon,1)
+    petBcoef(1:knon) = Dcoef_H(1:knon,1)
+    peqBcoef(1:knon) = Dcoef_Q(1:knon,1)
+
+  END SUBROUTINE climb_hq_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, gama, dels, X, Ccoef, Dcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is H or Q, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*dels(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*dels(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = dels(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Ccoef(i,1) = (X(i,1)*dels(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Dcoef(i,1) = -1. * RG / buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
+       flx_q1, flx_t1, paprs, pplay, &
+       flux_q, flux_h, d_q, d_t)
+! 
+! This routine calculates the flux and tendency of the specific humidity q and 
+! the potential engergi H. 
+! The quantities q and H are calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_t1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: zx_pkh, zx_pkf
+    REAL, DIMENSION(klon,klev)               :: h_new, q_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+!
+!****************************************************************************************
+    flux_q(:,:) = 0.0
+    flux_h(:,:) = 0.0
+    d_q(:,:)    = 0.0
+    d_t(:,:)    = 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+    DO k = 1, klev
+       DO i = 1, knon
+          zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA
+          zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA
+       END DO
+    END DO
+!****************************************************************************************
+! 2)
+! Calculation of Q and H
+!
+!****************************************************************************************
+
+!- First layer
+    q_new(1:knon,1) = Ccoef_Q(1:knon,1) + Dcoef_Q(1:knon,1)*flx_q1(1:knon)*dtime
+    h_new(1:knon,1) = Ccoef_H(1:knon,1) + Dcoef_H(1:knon,1)*flx_t1(1:knon)*dtime
+    
+!- All the rest layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
+          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for Q and H
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_q(1:knon,1)=flx_q1(1:knon)
+    flux_h(1:knon,1)=flx_t1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
+
+          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) / &
+               zx_pkh(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for Q and H
+!
+!****************************************************************************************
+
+    DO k = 1, klev
+       DO i = 1, knon
+          d_t(i,k) = h_new(i,k)/zx_pkf(i,k)/RCPD - t_old(i,k)
+          d_q(i,k) = q_new(i,k) - q_old(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H)    
+    DEALLOCATE(gamaq, gamah)
+    DEALLOCATE(Kcoefhq)
+
+    
+  END SUBROUTINE climb_hq_up
+!
+!****************************************************************************************
+!
+END MODULE climb_hq_mod
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/climb_wind_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/climb_wind_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/climb_wind_mod.F90	(revision 984)
@@ -0,0 +1,367 @@
+!
+! $Header$
+!
+MODULE climb_wind_mod
+!
+! Module to solve the verctical diffusion of the wind components "u" and "v".
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  SAVE
+  PRIVATE
+  
+  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
+  !$OMP THREADPRIVATE(alf1,alf2)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
+  !$OMP THREADPRIVATE(Kcoefm)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
+  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
+  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
+  LOGICAL                            :: firstcall=.TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+
+  
+  PUBLIC :: climb_wind_down, calcul_wind_flux, climb_wind_up
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_init
+
+    INTEGER             :: ierr
+    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
+
+!****************************************************************************************
+! Allocation of global module variables
+!
+!****************************************************************************************
+
+    ALLOCATE(alf1(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(alf2(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1)
+
+    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1)
+
+    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1)
+
+    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1)
+
+    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1)
+
+    firstcall=.FALSE.
+
+  END SUBROUTINE climb_wind_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old)
+!
+! This routine calculates for the wind components u and v,
+! recursivly the coefficients C and D in equation 
+! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
+!
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)                    :: u1lay, v1lay
+    INTEGER                                  :: k, i
+
+
+!****************************************************************************************
+! Initialize module
+    IF (firstcall) CALL climb_wind_init
+
+!****************************************************************************************
+! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
+!
+!****************************************************************************************
+
+! - Define alpha (alf1 and alf2) 
+    alf1(:) = 1.0
+    alf2(:) = 1.0 - alf1(:)
+
+! - Calculte the wind components for the first layer
+    u1lay(1:knon) = u_old(1:knon,1)*alf1(1:knon) + u_old(1:knon,2)*alf2(1:knon)
+    v1lay(1:knon) = v_old(1:knon,1)*alf1(1:knon) + v_old(1:knon,2)*alf2(1:knon)    
+
+! - Calculate K
+    Kcoefm(:,:) = 0.0
+    DO i = 1, knon
+       Kcoefm(i,1) = coef_in(i,1) * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))* &
+            pplay(i,1)/(RD*temp(i,1)) 
+       Kcoefm(i,1) = Kcoefm(i,1) * dtime*RG
+    END DO
+
+    DO k = 2, klev
+       DO i=1,knon
+          Kcoefm(i,k) = coef_in(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefm(i,k) = Kcoefm(i,k) * dtime*RG
+       END DO
+    END DO
+
+! - Calculate the coefficients C and D, component "u"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         u_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_U(:,:), Dcoef_U(:,:))
+
+! - Calculate the coefficients C and D, component "v"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         v_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_V(:,:), Dcoef_V(:,:))
+
+  END SUBROUTINE climb_wind_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, dels, X, alfa1, alfa2, Ccoef, Dcoef)
+!
+! Find the coefficients C and D in fonction of alfa, K and dels
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+  
+! local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! 
+! Niveau au sommet, k=klev
+!
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+
+       Ccoef(i,klev) = X(i,klev)*dels(i,klev)/buf 
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+    
+! 
+! Niveau  (klev-1) <= k <= 2
+!
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + &
+               Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          
+          Ccoef(i,k) = X(i,k)*dels(i,k) + &
+               Kcoef(i,k+1)*Ccoef(i,k+1)
+          Ccoef(i,k) = Ccoef(i,k)/buf         
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+! 
+! Niveau k=1
+!
+    DO i = 1, knon
+       buf = dels(i,1) + &
+            (alfa1(i) + alfa2(i)*Dcoef(i,2)) * Kcoef(i,1) + &
+            (1.-Dcoef(i,2))*Kcoef(i,2)
+       
+       Ccoef(i,1) = X(i,1)*dels(i,1) + &
+            (Kcoef(i,2)-Kcoef(i,1)*alfa2(i)) * Ccoef(i,2)
+       Ccoef(i,1) = Ccoef(i,1)/buf
+       Dcoef(i,1) = Kcoef(i,1)/buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE calcul_wind_flux(knon, dtime, &
+       flux_u, flux_v)
+
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    REAL, INTENT(IN)                     :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: u0, v0  ! u and v at niveau 0
+    REAL, DIMENSION(klon)                :: u1, v1  ! u and v at niveau 1
+    REAL, DIMENSION(klon)                :: u2, v2  ! u and v at niveau 2
+    
+
+!****************************************************************************************
+! Les vents de surface sont supposes nuls
+!
+!****************************************************************************************
+    u0(:) = 0.0
+    v0(:) = 0.0
+
+!****************************************************************************************
+! On calcule les vents du couhes 1 et 2 recurviement
+!
+!****************************************************************************************
+    DO i = 1, knon
+       u1(i) = Ccoef_U(i,1) + Dcoef_U(i,1)*u0(i)
+       v1(i) = Ccoef_V(i,1) + Dcoef_V(i,1)*v0(i)
+       u2(i) = Ccoef_U(i,2) + Dcoef_U(i,2)*u1(i)
+       v2(i) = Ccoef_V(i,2) + Dcoef_V(i,2)*v1(i)
+    END DO
+
+!****************************************************************************************
+! On calcule le flux
+!
+!****************************************************************************************
+    flux_u(:) = 0.0
+    flux_v(:) = 0.0
+
+    DO i=1,knon
+       flux_u(i) = Kcoefm(i,1)/RG/dtime * (u1(i)*alf1(i) + u2(i)*alf2(i) - u0(i)) 
+       flux_v(i) = Kcoefm(i,1)/RG/dtime * (v1(i)*alf1(i) + v2(i)*alf2(i) - v0(i)) 
+    END DO
+
+  END SUBROUTINE calcul_wind_flux
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, &
+       flx_u_new, flx_v_new, d_u_new, d_v_new)
+!
+! Diffuse the wind components from the surface and up to the top layer. Coefficents
+! C and D are known from before. The values for U and V at surface are supposed to be 
+! zero (this could be modified).
+!
+! u(k) = Cu(k) + Du(k)*u(k-1)
+! v(k) = Cv(k) + Dv(k)*v(k-1)
+! [1 <= k <= klev]
+!
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)              :: u_new, v_new
+    REAL, DIMENSION(klon)                   :: u0, v0
+    INTEGER                                 :: k, i
+    
+!
+!****************************************************************************************
+
+! Niveau 0
+    u0(1:knon) = 0.0
+    v0(1:knon) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       u_new(i,1) = Ccoef_U(i,1) + Dcoef_U(i,1) * u0(i)
+       v_new(i,1) = Ccoef_V(i,1) + Dcoef_V(i,1) * v0(i)
+    END DO
+
+! Niveau 2 jusqu'au sommet klev
+    DO k = 2, klev
+       DO i=1, knon
+          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
+          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul flux
+!
+!== flux_u/v est le flux de moment angulaire (positif vers bas)
+!== dont l'unite est: (kg m/s)/(m**2 s) 
+!
+!****************************************************************************************
+!
+    flx_u_new(:,:) = 0.0
+    flx_v_new(:,:) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       flx_u_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (u_new(i,1)*alf1(i)+u_new(i,2)*alf2(i) - u0(i)) 
+       flx_v_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (v_new(i,1)*alf1(i)+v_new(i,2)*alf2(i) - v0(i)) 
+    END DO
+
+! Niveau 2->klev
+    DO k = 2, klev
+       DO i = 1, knon
+          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (u_new(i,k)-u_new(i,k-1))
+          
+          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (v_new(i,k)-v_new(i,k-1))
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul tendances
+!
+!****************************************************************************************
+    d_u_new(:,:) = 0.0
+    d_v_new(:,:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
+          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
+       END DO
+    END DO
+
+  END SUBROUTINE climb_wind_up
+!
+!****************************************************************************************
+!
+END MODULE climb_wind_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clouds_gno.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clouds_gno.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/clouds_gno.F	(revision 984)
@@ -0,0 +1,250 @@
+!
+! $Header$
+!
+C
+C================================================================================
+C
+      SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF)
+      IMPLICIT NONE
+C     
+C--------------------------------------------------------------------------------
+C
+C Inputs:
+C
+C  ND----------: Number of vertical levels
+C  R--------ND-: Domain-averaged mixing ratio of total water 
+C  RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+C  QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+C                with SUBGRID-SCALE condensation processes (here, it is
+C                predicted by the convection scheme)
+C Outputs:
+C
+C  PTCONV-----ND-: Point convectif = TRUE
+C  RATQSC-----ND-: Largeur normalisee de la distribution
+C  CLDF-----ND-: Fraction nuageuse
+C
+C--------------------------------------------------------------------------------
+
+
+      INTEGER klon,ND
+      REAL R(klon,ND),  RS(klon,ND), QSUB(klon,ND)
+      LOGICAL PTCONV(klon,ND)
+      REAL RATQSC(klon,ND)
+      REAL CLDF(klon,ND)
+
+c -- parameters controlling the iteration:
+c --    nmax    : maximum nb of iterations (hopefully never reached)
+c --    epsilon : accuracy of the numerical resolution 
+c --    vmax    : v-value above which we use an asymptotic expression for ERF(v)
+
+      INTEGER nmax
+      PARAMETER ( nmax = 10) 
+      REAL epsilon, vmax0, vmax(klon)
+      PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) 
+
+      REAL min_mu, min_Q
+      PARAMETER ( min_mu =  1.e-12, min_Q=1.e-12 )
+     
+      INTEGER i,K, n, m
+      REAL mu(klon), qsat(klon), delta(klon), beta(klon) 
+      real zu2(klon),zv2(klon)
+      REAL xx(klon), aux(klon), coeff(klon), block(klon)
+      REAL  dist(klon), fprime(klon), det(klon)
+      REAL pi, u(klon), v(klon), erfcu(klon), erfcv(klon)
+      REAL  xx1(klon), xx2(klon)
+      real erf,kkk
+      real sqrtpi,sqrt2,zx1,zx2,exdel
+c lconv = true si le calcul a converge (entre autre si qsub < min_q)
+       LOGICAL lconv(klon)
+
+cym
+      cldf(:,:)=0.0
+      
+      pi = ACOS(-1.)
+      sqrtpi=sqrt(pi)
+      sqrt2=sqrt(2.)
+
+      ptconv=.false.
+      ratqsc=0.
+
+
+      DO 500 K = 1, ND
+
+                                    do i=1,klon ! vector
+      mu(i) = R(i,K)
+      mu(i) = MAX(mu(i),min_mu)
+      qsat(i) = RS(i,K) 
+      qsat(i) = MAX(qsat(i),min_mu)
+      delta(i) = log(mu(i)/qsat(i))
+                                    enddo ! vector
+
+C
+C ***          There is no subgrid-scale condensation;        ***
+C ***   the scheme becomes equivalent to an "all-or-nothing"  *** 
+C ***             large-scale condensation scheme.            ***
+C
+
+C
+C ***     Some condensation is produced at the subgrid-scale       ***
+C ***                                                              ***
+C ***       PDF = generalized log-normal distribution (GNO)        ***
+C ***   (k<0 because a lower bound is considered for the PDF)      ***
+C ***                                                              ***
+C ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+C ***  that the contribution of subgrid-scale processes to         ***
+C ***  the in-cloud water content is equal to QSUB(K)              ***
+C ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+C ***                                                              ***
+C ***    Here, an iterative method is used for this purpose        ***
+C ***    (other numerical methods might be more efficient)         ***
+C ***                                                              ***
+C ***          NB: the "error function" is called ERF              ***
+C ***                 (ERF in double precision)                   ***
+C
+
+c  On commence par eliminer les cas pour lesquels on n'a pas
+c  suffisamment d'eau nuageuse.
+
+                                    do i=1,klon ! vector
+
+      IF ( QSUB(i,K) .lt. min_Q ) THEN
+        ptconv(i,k)=.false.
+        ratqsc(i,k)=0.
+        lconv(i)  = .true.
+
+c   Rien on a deja initialise
+
+      ELSE 
+
+        lconv(i)  = .FALSE. 
+        vmax(i) = vmax0
+
+        beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) )
+
+c --  roots of equation v > vmax:
+
+        det(i) = delta(i) + vmax(i)**2.
+        if (det(i).LE.0.0) vmax(i) = vmax0 + 1.0
+        det(i) = delta(i) + vmax(i)**2.
+
+        if (det(i).LE.0.) then
+          xx(i) = -0.0001
+        else 
+         zx1=-sqrt2*vmax(i)
+         zx2=SQRT(1.0+delta(i)/(vmax(i)**2.))
+         xx1(i)=zx1*(1.0-zx2)
+         xx2(i)=zx1*(1.0+zx2)
+         xx(i) = 1.01 * xx1(i)
+         if ( xx1(i) .GE. 0.0 ) xx(i) = 0.5*xx2(i)
+        endif
+        if (delta(i).LT.0.) xx(i) = -0.5*SQRT(log(2.)) 
+
+      ENDIF
+
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Debut des nmax iterations pour trouver la solution.
+c----------------------------------------------------------------------
+
+      DO n = 1, nmax 
+
+                                    do i=1,klon ! vector
+        if (.not.lconv(i)) then
+
+          u(i) = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
+          v(i) = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
+
+          IF ( v(i) .GT. vmax(i) ) THEN 
+
+            IF (     ABS(u(i))  .GT. vmax(i) 
+     :          .AND.  delta(i) .LT. 0. ) THEN
+
+c -- use asymptotic expression of erf for u and v large:
+c ( -> analytic solution for xx )
+             exdel=beta(i)*EXP(delta(i))
+             aux(i) = 2.0*delta(i)*(1.-exdel)
+     :                       /(1.+exdel)
+             if (aux(i).lt.0.) then
+c                print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i)=0.
+             endif
+             xx(i) = -SQRT(aux(i))
+             block(i) = EXP(-v(i)*v(i)) / v(i) / sqrtpi
+             dist(i) = 0.0
+             fprime(i) = 1.0
+
+            ELSE
+
+c -- erfv -> 1.0, use an asymptotic expression of erfv for v large:
+
+             erfcu(i) = 1.0-ERF(u(i))
+c  !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+             aux(i) = sqrtpi*erfcu(i)*EXP(min(v(i)*v(i),100.))
+             coeff(i) = 1.0 - 1./2./(v(i)**2.) + 3./4./(v(i)**4.)
+             block(i) = coeff(i) * EXP(-v(i)*v(i)) / v(i) / sqrtpi
+             dist(i) = v(i) * aux(i) / coeff(i) - beta(i)
+             fprime(i) = 2.0 / xx(i) * (v(i)**2.)
+     :           * ( coeff(i)*EXP(-delta(i)) - u(i) * aux(i) )
+     :           / coeff(i) / coeff(i)
+            
+            ENDIF ! ABS(u)
+
+          ELSE
+
+c -- general case:
+
+           erfcu(i) = 1.0-ERF(u(i))
+           erfcv(i) = 1.0-ERF(v(i))
+           block(i) = erfcv(i)
+           dist(i) = erfcu(i) / erfcv(i) - beta(i)
+           zu2(i)=u(i)*u(i)
+           zv2(i)=v(i)*v(i)
+           if(zu2(i).gt.20..or. zv2(i).gt.20.) then
+c              print*,'ATTENTION !!! xx(',i,') =', xx(i)
+c           print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+c     .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+c     .CLDF(i,k)
+c              print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2(i)=20.
+              zv2(i)=20.
+             fprime(i) = 0.
+           else
+             fprime(i) = 2. /sqrtpi /xx(i) /erfcv(i)**2.
+     :           * (   erfcv(i)*v(i)*EXP(-zu2(i))
+     :               - erfcu(i)*u(i)*EXP(-zv2(i)) )
+           endif
+          ENDIF ! x
+
+c -- test numerical convergence:
+
+c         print*,'avant test ',i,k,lconv(i),u(i),v(i)
+          if ( ABS(dist(i)/beta(i)) .LT. epsilon ) then 
+c           print*,'v-u **2',(v(i)-u(i))**2
+c           print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i,K) = .TRUE. 
+            lconv(i)=.true.
+c  borne pour l'exponentielle
+            ratqsc(i,k)=min(2.*(v(i)-u(i))**2,20.)
+            ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.)
+            CLDF(i,K) = 0.5 * block(i)
+          else
+            xx(i) = xx(i) - dist(i)/fprime(i)
+          endif
+c         print*,'apres test ',i,k,lconv(i)
+
+        endif ! lconv
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Fin des nmax iterations pour trouver la solution.
+        ENDDO ! n
+c----------------------------------------------------------------------
+
+500   CONTINUE  ! K
+
+       RETURN
+       END
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cltrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cltrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cltrac.F	(revision 984)
@@ -0,0 +1,122 @@
+!
+! $Header$
+!
+      SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp,
+     s                  d_tr)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+c            inspire de clvent
+c Objet: diffusion verticale de traceurs avec flux fixe a la surface
+c        ou/et flux du type c-drag
+c======================================================================
+c Arguments:
+c dtime----input-R- intervalle du temps (en second)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c tr-------input-R- la q. de traceurs
+c flux-----input-R- le flux de traceurs a la surface
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c cdrag----input-R- cdrag pour le flux de surface (non active)
+c tr0------input-R- traceurs a la surface ou dans l'ocean (non active)
+c d_tr-----output-R- le changement de tr
+c flux_tr--output-R- flux de tr
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL dtime
+      REAL coef(klon,klev)
+      REAL t(klon,klev), tr(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL d_tr(klon,klev)
+      REAL flux(klon), cdrag(klon), tr0(klon)
+c      REAL flux_tr(klon,klev)
+c======================================================================
+#include "YOMCST.h"
+c======================================================================
+      INTEGER i, k
+      REAL zx_ctr(klon,2:klev)
+      REAL zx_dtr(klon,2:klev)
+      REAL zx_buf(klon)
+      REAL zx_coef(klon,klev)
+      REAL local_tr(klon,klev)
+      REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon)
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+
+c======================================================================
+      DO i = 1, klon
+         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alf2(i) = 1.0 - zx_alf1(i)
+         zx_flux(i) =  -flux(i)*dtime*RG
+c--pour le moment le flux est prescrit
+c--cdrag et zx_coef(1) vaut 0
+         cdrag(i) = 0.0 
+         tr0(i) = 0.0
+         zx_coef(i,1) = cdrag(i)*dtime*RG 
+      ENDDO
+c======================================================================
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k)*dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+         zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+
+     .                  zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+         zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / 
+     .                  zx_buf(i)
+      ENDDO
+c
+      DO k = 3, klev
+      DO i = 1, klon
+         zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
+     .                  + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+         zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)
+     .                  +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+         zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev)
+     .                        +zx_coef(i,klev)*zx_ctr(i,klev) )
+     .                   / ( delp(i,klev) + zx_coef(i,klev)
+     .                       -zx_coef(i,klev)*zx_dtr(i,klev) )
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== flux_tr est le flux de traceur (positif vers bas)
+c      DO i = 1, klon
+c         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+c     .               * (local_tr(i,k)-local_tr(i,k-1))
+c      ENDDO
+c      ENDDO
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         d_tr(i,k) = local_tr(i,k) - tr(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cltracrn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cltracrn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cltracrn.F	(revision 984)
@@ -0,0 +1,294 @@
+!
+! $Header$
+!
+      SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay,
+     e              coef,t,ftsol,pctsrf,
+     e              tr,trs,paprs,pplay,delp,
+     e              masktr,fshtr,hsoltr,tautr,vdeptr,
+     e              lat,
+     s              d_tr,d_trs )
+
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Alex/LMD) date:  fev 99
+c            inspire de clqh + clvent
+c Objet: diffusion verticale de traceurs avec quantite de traceur ds 
+c        le sol ( reservoir de sol de radon ) 
+c        
+c note : pour l'instant le traceur dans le sol et le flux sont
+c        calcules mais ils ne servent que de diagnostiques
+c        seule la tendance sur le traceur est sortie (d_tr)
+c======================================================================
+c Arguments:
+c itr---  -input-R- le type de traceur 1- Rn 2 - Pb
+c dtime----input-R- intervalle du temps (en second)
+c u1lay----input-R- vent u de la premiere couche (m/s)
+c v1lay----input-R- vent v de la premiere couche (m/s)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c ftsol----input-R- temperature du sol (en Kelvin)
+c tr-------input-R- traceurs
+c trs------input-R- traceurs dans le sol
+c masktr---input-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----input-R- Flux surfacique de production dans le sol
+c tautr----input-R- Constante de decroissance du traceur
+c vdeptr---input-R- Vitesse de depot sec dans la couche brownienne
+c hsoltr---input-R- Epaisseur equivalente du reservoir de sol
+c lat-----input-R- latitude en degree
+c d_tr-----output-R- le changement de "tr"
+c d_trs----output-R- le changement de "trs"
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c======================================================================
+      REAL dtime
+      REAL u1lay(klon), v1lay(klon)
+      REAL coef(klon,klev)
+      REAL t(klon,klev), ftsol(klon,nbsrf), pctsrf(klon,nbsrf) 
+      REAL tr(klon,klev), trs(klon)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL masktr(klon) 
+      REAL fshtr(klon) 
+      REAL hsoltr
+      REAL tautr
+      REAL vdeptr
+      REAL lat(klon)   
+      REAL d_tr(klon,klev)
+c======================================================================
+      REAL flux_tr(klon,klev)  ! (diagnostic) flux de traceur
+      REAL d_trs(klon)         ! (diagnostic) traceur ds le sol
+c======================================================================
+      INTEGER i, k, itr, n, l
+      REAL rotrhi(klon)
+      REAL zx_coef(klon,klev)
+      REAL zx_buf(klon)
+      REAL zx_ctr(klon,klev)
+      REAL zx_dtr(klon,klev)
+      REAL zx_trs(klon)
+      REAL zx_a, zx_b
+
+      REAL local_tr(klon,klev)
+      REAL local_trs(klon)
+      REAL zts(klon)
+      REAL zx_alpha1(klon), zx_alpha2(klon)
+c======================================================================
+cAA Pour l'instant les 4 types de surface ne sont pas pris en compte
+cAA On fabrique avec zts un champ de temperature de sol  
+cAA que le pondere par la fraction de nature de sol.
+c 
+c      print*,'PASSAGE DANS CLTRACRN'
+
+      DO i = 1,klon
+            zts(i) = 0. 
+      ENDDO
+c
+      DO n=1,nbsrf
+         DO i = 1,klon
+            zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
+         ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+          rotrhi(i) = RD * zts(i) / hsoltr 
+      END DO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         local_trs(i) = trs(i)
+      ENDDO
+c======================================================================
+cAA   Attention si dans clmain zx_alf1(i) = 1.0 
+cAA   Il doit y avoir coherence (dc la meme chose ici)
+
+      DO i = 1, klon
+cAA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alpha1(i) = 1.0
+         zx_alpha2(i) = 1.0 - zx_alpha1(i)
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_coef(i,1) = coef(i,1)
+     .                 * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))
+     .                 * pplay(i,1)/(RD*t(i,1))
+         zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+      ENDDO
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
+         zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
+         zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
+      ENDDO
+c
+      DO l = klev-1, 2 , -1
+      DO i = 1, klon
+         zx_buf(i) = delp(i,l)+zx_coef(i,l)
+     .              +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
+         zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l)
+     .                   + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
+         zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))
+     .               + masktr(i) * zx_coef(i,1)
+     .               *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
+         zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)
+     .                  + zx_ctr(i,2)
+     .                  *(zx_coef(i,2)
+     .                    - masktr(i) * zx_coef(i,1)
+     .                    *zx_alpha2(i) ) ) / zx_buf(i)
+         zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
+      ENDDO
+c======================================================================
+c Calculer d'abord local_trs nouvelle quantite dans le reservoir
+c de sol
+c
+c-------------------------
+c Au dessus des continents
+c-------------------------
+c Le pb peut se deposer partout : vdeptr = 10-3 m/s
+c Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
+c
+      DO i = 1, klon
+c
+        IF ( NINT(masktr(i)) .EQ. 1 ) THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +fshtr(i)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+cAA: Pour l'instant, pour aller vite, le depot sec est traite
+C comme une decroissance
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c Si on est entre 60N et 70N on divise par 2 l'emanation
+c--------------------------------------------------------
+c
+        IF
+     .  ( (itr.eq.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.)
+     .                      .OR.
+     .     (itr.eq.2.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.) )
+     .  THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +(fshtr(i)/2.)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c----------------------------------------------
+c Au dessus des oceans et aux hautes latitudes
+c----------------------------------------------
+c
+c au dessous de -60S  pas d'emission de radon au dessus 
+c des oceans et des continents
+c---------------------------------------------------------------
+
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c au dessus de 70 N pas d'emission de radon au dessus 
+c des oceans et des continents
+c--------------------------------------------------------------
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c Au dessus des oceans la source est nulle
+c-----------------------------------------
+c
+        IF (itr.eq.1.AND.NINT(masktr(i)).EQ.0) THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+c
+      ENDDO    ! sur le i=1,klon
+c
+c======================================================================
+c==== une fois on a zx_trs, on peut faire l'iteration ========
+c
+      DO i = 1, klon
+         local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        local_tr(i,l)
+     .    = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul du flux de traceur (flux_tr): UA/(m**2 s)
+c
+      DO i = 1, klon
+        flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG
+     .      * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2)
+     .                   -zx_trs(i)) / dtime
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        flux_tr(i,l) = zx_coef(i,l)/RG
+     .       * (local_tr(i,l)-local_tr(i,l-1)) / dtime
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul des tendances du traceur ds le sol et dans l'atmosphere
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_tr(i,l) = local_tr(i,l) - tr(i,l)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         d_trs(i) = local_trs(i) - trs(i)
+      ENDDO
+c======================================================================
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coef_diff_turb_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coef_diff_turb_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coef_diff_turb_mod.F90	(revision 984)
@@ -0,0 +1,675 @@
+!
+! $Header$
+!
+MODULE coef_diff_turb_mod
+!
+! This module contains some procedures for calculation of the coefficients of the
+! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
+! at surface(cdrag)
+!
+  USE dimphy
+  
+  IMPLICIT NONE
+  
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, &
+       ycoefm, ycoefh)
+! 
+! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+! atmosphere and coefficients for turbulent diffusion at surface - cdrag
+! (ycoefm(:,1), ycoefh(:,1)).
+!
+!
+! Input arguments
+!****************************************************************************************
+    REAL, INTENT(IN)                           :: dtime
+    INTEGER, INTENT(IN)                        :: nsrf, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE  :: q2save
+    !$OMP THREADPRIVATE(q2save)
+    LOGICAL, SAVE                              :: first_call=.TRUE.
+    !$OMP THREADPRIVATE(first_call)    
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                    :: k, i, j
+    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
+    REAL, DIMENSION(klon,klev+1)               :: yzlev, yq2, q2diag, ykmm, ykmn, ykmq
+    REAL, DIMENSION(klon)                      :: y_cd_h, y_cd_m
+    REAL, DIMENSION(klon)                      :: yustar
+
+! Include
+!****************************************************************************************
+    INCLUDE "clesphys.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "YOMCST.h"
+
+!****************************************************************************************
+! Start calculation
+! - Initilalize output variables 
+!****************************************************************************************
+
+    ycoefm(:,:) = 0.0
+    ycoefh(:,:) = 0.0
+
+
+!****************************************************************************************    
+! Methode 1 :
+!
+!****************************************************************************************    
+
+    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
+         ksta, ksta_ter, &
+         yts, yrugos, yu, yv, yt, yq, &
+         yqsurf, &
+         ycoefm, ycoefh)
+  
+!****************************************************************************************
+! Methode 2 :
+!
+!****************************************************************************************
+
+    IF (iflag_pbl.EQ.1) THEN
+       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
+            ycoefm0, ycoefh0)
+
+       DO k = 1, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+    ENDIF
+
+!****************************************************************************************
+! IM cf JLD : on seuille ycoefm et ycoefh
+!
+!****************************************************************************************
+    IF (nsrf.EQ.is_oce) THEN
+       DO j=1,knon
+          ycoefm(j,1)=MIN(ycoefm(j,1),cdmmax)
+          ycoefh(j,1)=MIN(ycoefh(j,1),cdhmax)
+       ENDDO
+    ENDIF
+  
+!****************************************************************************************  
+! Calcul d'une diffusion minimale pour les conditions tres stables
+!
+!****************************************************************************************
+    IF (ok_kzmin) THEN
+       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycoefm, &
+            ycoefm0,ycoefh0)
+       
+       DO k = 1, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+       
+    ENDIF
+
+  
+!****************************************************************************************
+! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
+! Methode 3 :
+!****************************************************************************************
+
+    IF (iflag_pbl.GE.3) THEN
+
+       IF (first_call) THEN
+          PRINT*, "Using method MELLOR&YAMADA"
+          ! NB! q2save could/should be read and written from (re)startphy.nc
+          ALLOCATE(q2save(klon,klev+1,nbsrf))
+          q2save(:,:,:) = 1.e-8
+          first_call=.FALSE.
+       END IF
+
+       yzlay(1:knon,1)= &
+            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+          DO i = 1, knon
+             yzlay(i,k)= &
+                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
+                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+          END DO
+       END DO
+
+       DO k=1,klev
+          DO i = 1, knon
+             yteta(i,k)= &
+                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
+                  *(1.+0.61*yq(i,k))
+          END DO
+       END DO
+
+       yzlev(1:knon,1)=0.
+       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
+       DO k=2,klev
+          DO i = 1, knon
+             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+          END DO
+       END DO
+
+! Compresse q2save
+       DO k = 1, klev+1
+          DO j = 1, knon
+             i = ni(j)
+             yq2(j,k)=q2save(i,k,nsrf)
+          ENDDO
+       ENDDO
+         
+!   Bug introduit volontairement pour converger avec les resultats
+!   du papier sur les thermiques.
+       IF (1.EQ.1) THEN
+          y_cd_m(1:knon) = ycoefm(1:knon,1)
+          y_cd_h(1:knon) = ycoefh(1:knon,1)
+       ELSE
+          y_cd_h(1:knon) = ycoefm(1:knon,1)
+          y_cd_m(1:knon) = ycoefh(1:knon,1)
+       ENDIF
+       
+       CALL ustarhb(knon,yu,yv,y_cd_m, yustar)
+     
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*) 'USTAR = ',yustar
+       ENDIF
+         
+!   iflag_pbl peut etre utilise comme longuer de melange
+       IF (iflag_pbl.GE.11) THEN
+          CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,q2diag,ykmm,ykmn,yustar, &
+               iflag_pbl)
+       ELSE
+          CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,ykmm,ykmn,ykmq,yustar, &
+               iflag_pbl)
+       ENDIF
+       
+       ycoefm(1:knon,1)=y_cd_m(1:knon)
+       ycoefh(1:knon,1)=y_cd_h(1:knon)
+       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
+       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
+                
+! update q2save with yq2
+       DO j=1,knon
+          DO k=1,klev+1
+             i=ni(j)
+             q2save(i,k,nsrf) = yq2(j,k)
+          END DO
+       END DO
+       
+    ENDIF !(iflag_pbl.ge.3)
+
+  END SUBROUTINE coef_diff_turb
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
+       ksta, ksta_ter, &
+       ts, rugos, &
+       u,v,t,q, &
+       qsurf, &
+       pcfm, pcfh)
+    
+!======================================================================
+! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+!           (une version strictement identique a l'ancien modele)
+! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+!        coefficients d'echange turbulent dans l'atmosphere.
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pregssion a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! ts-------input-R- temperature du sol (en Kelvin)
+! rugos----input-R- longeur de rugosite (en m)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOMCST.h"
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                      :: knon, nsrf
+    REAL, DIMENSION(klon), INTENT(IN)        :: ts
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
+
+
+! Local variables
+
+! numero de couche du sommet de la couche limite
+    INTEGER, DIMENSION(klon)    :: itop
+!
+! Quelques constantes et options:
+!
+    REAL cepdu2, ckap, cb, cc, cd, clam
+    PARAMETER (cepdu2 =(0.1)**2)
+    PARAMETER (CKAP=0.4)
+    PARAMETER (cb=5.0)
+    PARAMETER (cc=5.0)
+    PARAMETER (cd=5.0)
+    PARAMETER (clam=160.0)
+    REAL ratqs ! largeur de distribution de vapeur d'eau
+    PARAMETER (ratqs=0.05)
+    LOGICAL richum ! utilise le nombre de Richardson humide
+    PARAMETER (richum=.TRUE.)
+    REAL ric ! nombre de Richardson critique
+    PARAMETER(ric=0.4)
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable ! diffusion minimale (situation stable)
+    ! GKtest
+    ! PARAMETER (kstable=1.0e-10)
+    REAL ksta, ksta_ter
+!IM: 261103     REAL kstable_ter, kstable_sinon
+!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
+!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
+!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
+!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
+    ! fin GKtest
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    INTEGER isommet ! le sommet de la couche limite
+    LOGICAL tvirtu ! calculer Ri d'une maniere plus performante
+    PARAMETER (tvirtu=.TRUE.)
+    LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
+    PARAMETER (opt_ec=.FALSE.)
+
+!
+! Variables locales:
+
+    INTEGER i, k !IM 120704
+    REAL zgeop(klon,klev)
+    REAL zmgeom(klon)
+    REAL zri(klon)
+    REAL zl2(klon)
+    
+    REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon)
+    REAL pcfm1(klon), pcfh1(klon)
+
+    REAL zdphi, zdu2, ztvd, ztvu, zcdn
+    REAL zscf
+    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+    REAL t_coup
+    PARAMETER (t_coup=273.15)
+!IM
+    LOGICAL check
+    PARAMETER (check=.FALSE.)
+!
+! contre-gradient pour la chaleur sensible: Kelvin/metre
+    REAL gamt(2:klev)
+    REAL qsurf(klon) 
+
+    LOGICAL, SAVE :: appel1er
+    !$OMP THREADPRIVATE(appel1er)
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+    REAL fsta, fins, x
+    LOGICAL zxli ! utiliser un jeu de fonctions simples
+    PARAMETER (zxli=.FALSE.)
+
+    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+    fins(x) = SQRT(1.0-18.0*x)
+
+    DATA appel1er /.TRUE./
+
+
+    isommet=klev
+      
+    IF (appel1er) THEN
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
+          WRITE(lunout,*)'coefkz, richum:', richum
+          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
+          WRITE(lunout,*)'coefkz, isommet:', isommet
+          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
+          appel1er = .FALSE.
+       ENDIF
+    ENDIF
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+    DO i = 1, knon
+       itop(i) = 0
+    ENDDO
+    
+!
+! Prescrire la valeur de contre-gradient
+!
+    IF (iflag_pbl.EQ.1) THEN
+       DO k = 3, klev
+          gamt(k) = -1.0E-03
+       ENDDO
+       gamt(2) = -2.5E-03
+    ELSE
+       DO k = 2, klev
+          gamt(k) = 0.0
+       ENDDO
+    ENDIF
+!IM cf JLD/ GKtest
+    IF ( nsrf .NE. is_oce ) THEN
+!IM 261103     kstable = kstable_ter
+       kstable = ksta_ter
+    ELSE
+!IM 261103     kstable = kstable_sinon
+       kstable = ksta
+    ENDIF
+!IM cf JLD/ GKtest fin
+
+!
+! Calculer les geopotentiels de chaque couche
+!
+    DO i = 1, knon
+       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+            * (paprs(i,1)-pplay(i,1))
+    ENDDO
+    DO k = 2, klev
+       DO i = 1, knon
+          zgeop(i,k) = zgeop(i,k-1) &
+               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+               * (pplay(i,k-1)-pplay(i,k))
+       ENDDO
+    ENDDO
+
+!
+! Calculer le frottement au sol (Cdrag)
+!
+    DO i = 1, knon
+       u1(i) = u(i,1)
+       v1(i) = v(i,1)
+       t1(i) = t(i,1)
+       q1(i) = q(i,1)
+       z1(i) = zgeop(i,1)
+    ENDDO
+
+    CALL clcdrag(klon, knon, nsrf, zxli, &
+         u1, v1, t1, q1, z1, &
+         ts, qsurf, rugos, &
+         pcfm1, pcfh1) 
+!IM               ts, qsurf, rugos,
+
+    DO i = 1, knon
+       pcfm(i,1)=pcfm1(i)
+       pcfh(i,1)=pcfh1(i)
+    ENDDO
+!
+! Calculer les coefficients turbulents dans l'atmosphere
+!
+    DO i = 1, knon
+       itop(i) = isommet
+    ENDDO
+
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
+               +(v(i,k)-v(i,k-1))**2)
+          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+          zdphi =zmgeom(i) / 2.0
+          zt = (t(i,k)+t(i,k-1)) * 0.5
+          zq = (q(i,k)+q(i,k-1)) * 0.5
+
+!
+! Calculer Qs et dQs/dT:
+!
+          IF (thermcep) THEN
+             zdelta = MAX(0.,SIGN(1.,RTT-zt))
+             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
+                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+             zqs = MIN(0.5,zqs)
+             zcor = 1./(1.-RETV*zqs)
+             zqs = zqs*zcor
+             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+          ELSE
+             IF (zt .LT. t_coup) THEN
+                zqs = qsats(zt) / pplay(i,k)
+                zdqs = dqsats(zt,zqs)
+             ELSE
+                zqs = qsatl(zt) / pplay(i,k)
+                zdqs = dqsatl(zt,zqs)
+             ENDIF
+          ENDIF
+!
+!           calculer la fraction nuageuse (processus humide):
+!
+          zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+          zfr = MAX(0.0,MIN(1.0,zfr))
+          IF (.NOT.richum) zfr = 0.0
+!
+!           calculer le nombre de Richardson:
+!
+          IF (tvirtu) THEN
+             ztvd =( t(i,k) &
+                  + zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k))
+             ztvu =( t(i,k-1) &
+                  - zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k-1))
+             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+             zri(i) = zri(i) &
+                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(ztvd+ztvu))
+
+          ELSE ! calcul de Ridchardson compatible LMD5
+
+             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
+                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
+                  *(pplay(i,k)-pplay(i,k-1)) &
+                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+             zri(i) = zri(i) + &
+                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+          ENDIF
+!
+!           finalement, les coefficients d'echange sont obtenus:
+!
+          zcdn=SQRT(zdu2) / zmgeom(i) * RG
+
+          IF (opt_ec) THEN
+             z2geomf=zgeop(i,k-1)+zgeop(i,k)
+             zalm2=(0.5*ckap/RG*z2geomf &
+                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
+             zalh2=(0.5*ckap/rg*z2geomf &
+                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+             IF (zri(i).LT.0.0) THEN  ! situation instable
+                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
+                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+                zscf = SQRT(-zri(i)*zscf)
+                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+             ELSE ! situation stable
+                zscf=SQRT(1.+cd*zri(i))
+                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+             ENDIF
+          ELSE
+             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
+                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+             pcfm(i,k)= zl2(i)* pcfm(i,k)
+             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Au-dela du sommet, pas de diffusion turbulente:
+!
+    DO i = 1, knon
+       IF (itop(i)+1 .LE. klev) THEN
+          DO k = itop(i)+1, klev
+             pcfh(i,k) = 0.0
+             pcfm(i,k) = 0.0
+          ENDDO
+       ENDIF
+    ENDDO
+      
+  END SUBROUTINE coefkz
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
+       pcfm, pcfh)
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: knon, nsrf
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
+    
+    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
+!
+! Quelques constantes et options:
+!
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable
+    PARAMETER (kstable=0.002)
+!    PARAMETER (kstable=0.001)
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    REAL seuil ! au-dela l'inversion est consideree trop faible
+    PARAMETER (seuil=-0.02)
+!    PARAMETER (seuil=-0.04)
+!    PARAMETER (seuil=-0.06)
+!    PARAMETER (seuil=-0.09)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(knon)
+    REAL zl2(knon)
+    REAL zdthmin(knon), zdthdp
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+
+!
+! Chercher la zone d'inversion forte
+!
+    DO i = 1, knon
+       invb(i) = klev
+       zdthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, knon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.zdthmin(i) ) THEN
+             zdthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Introduire une diffusion:
+!
+    IF ( nsrf.EQ.is_oce ) THEN
+       DO k = 2, klev
+          DO i = 1, knon
+!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+      !IM cf JLD/ GKtest TERkz2
+      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
+      ! fin GKtest
+
+
+! s'il n'y a pas d'inversion ou si l'inversion est trop faible
+!          IF ( (nsrf.EQ.is_oce) .AND. &
+             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
+                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
+                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
+                pcfm(i,k)= zl2(i)* kstable
+                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE coefkz2
+!
+!****************************************************************************************
+!
+END MODULE coef_diff_turb_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coefcdrag.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coefcdrag.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coefcdrag.F90	(revision 984)
@@ -0,0 +1,147 @@
+!
+! $Header$
+!
+!
+!
+!
+      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
+                            speed, t, q, zgeop, psol, &
+                            ts, qsurf, rugos, okri, ri1, &
+                            cdram, cdrah, cdran, zri1, pref)
+      IMPLICIT none
+!-------------------------------------------------------------------------
+! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
+!         sensible et latente (cdrah), du cdrag neutre (cdran), 
+!         du nombre de Richardson entre la surface et le niveau de reference 
+!         (zri1) et de la pression au niveau de reference (pref).    
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! psol----input-R- pression au sol 
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
+!
+! cdram--output-R- cdrag pour le moment
+! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
+! cdran--output-R- cdrag neutre
+! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
+! pref---output-R- pression au niveau zgeop/RG
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli 
+      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
+      LOGICAL, intent(in) :: okri    
+!
+      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
+!-------------------------------------------------------------------------
+!
+      include "YOMCST.h"
+      include "YOETHF.h"
+      include "indicesol.h"
+! Quelques constantes :
+      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0
+!
+! Variables locales :
+      INTEGER :: i
+      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
+      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
+      REAL, dimension(klon) :: zcfm1, zcfh1
+      REAL, dimension(klon) :: zcfm2, zcfh2
+      REAL, dimension(klon) :: trm0, trm1
+!-------------------------------------------------------------------------
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+!-------------------------------------------------------------------------
+!
+      DO i = 1, knon
+!
+       zdphi(i) = zgeop(i)
+       zdu2(i) = speed(i)**2
+       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
+                 (1.+ RETV * max(q(i),0.0))))
+       ztsolv(i) = ts(i)
+       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
+       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
+       trm1(i) = 1. + RETV * max(q(i),0.0)
+       ztsolv(i) = ztsolv(i) * trm0(i)
+       ztvd(i) = ztvd(i) * trm1(i)
+       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
+!
+! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
+!
+!IM +++
+       IF(1.EQ.0) THEN
+       IF (okri) THEN
+         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
+           zri1(i) = ri1(i)
+         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
+           zri1(i) = ri1(i)
+         ENDIF 
+       ENDIF
+       ENDIF
+!IM ---
+! 
+       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
+
+       IF (zri1(i) .ge. 0.) THEN 
+!
+! situation stable : pour eviter les inconsistances dans les cas 
+! tres stables on limite zri1 a 20. cf Hess et al. (1995)
+!
+         zri1(i) = min(20.,zri1(i))
+!
+         IF (.NOT.zxli) THEN
+           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
+           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1)
+           zcfm1(i) = cdran(i) * friv(i)
+           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 )
+           zcfh1(i) = cdran(i) * frih(i)
+           cdram(i) = zcfm1(i)
+           cdrah(i) = zcfh1(i)
+         ELSE
+           cdram(i) = cdran(i)* fsta(zri1(i))
+           cdrah(i) = cdran(i)* fsta(zri1(i))
+         ENDIF
+!
+       ELSE
+! 
+! situation instable
+!
+         IF (.NOT.zxli) THEN
+           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
+                 *(1.0+zdphi(i)/(RG*rugos(i)))))
+           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1)
+           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
+           cdram(i) = zcfm2(i)
+           cdrah(i) = zcfh2(i)
+         ELSE
+           cdram(i) = cdran(i)* fins(zri1(i))
+           cdrah(i) = cdran(i)* fins(zri1(i))
+         ENDIF
+!
+! cdrah sur l'ocean cf. Miller et al. (1992)
+!
+         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
+               **(1./3.)
+         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
+                  **(1./1.25)
+       ENDIF
+!
+      END DO
+      RETURN 
+      END SUBROUTINE coefcdrag
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coefkzmin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coefkzmin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/coefkzmin.F	(revision 984)
@@ -0,0 +1,136 @@
+!
+! $Header$
+!
+       SUBROUTINE coefkzmin(ngrid,ypaprs,ypplay,yu,yv,yt,yq,ycoefm
+     .   ,km,kn)
+c      SUBROUTINE coefkzmin(ngrid,zlev,teta,ustar,km,kn)
+      USE dimphy
+      IMPLICIT NONE
+
+      include "YOMCST.h"
+
+c.......................................................................
+c  Entrees modifies en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+
+      REAL  ycoefm(klon,klev)
+
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      REAL ypaprs(klon,klev+1), ypplay(klon,klev)
+      REAL yustar(klon)
+      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
+
+      integer i
+
+c.......................................................................
+c
+c  En entree :
+c  -----------
+c
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c ustar : u*
+c
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c
+c  en sortier :
+c  ------------
+c
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL teta(klon,klev)
+
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer ngrid
+
+
+      integer nlay,nlev
+      integer ig,k
+
+      real,parameter :: kap=0.4
+
+      nlay=klev
+      nlev=klev+1
+c.......................................................................
+c  en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+c  Debut de la partie qui doit etre unclue a terme dans clmain.
+c
+         do i=1,ngrid
+            yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1)))
+     .                *(ypaprs(i,1)-ypplay(i,1))/RG
+         enddo
+         do k=2,klev
+            do i=1,ngrid
+               yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k))
+     s                /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+            enddo
+         enddo
+         do k=1,klev
+            do i=1,ngrid
+cATTENTION:on passe la temperature potentielle virt. pour le calcul de K
+             yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa
+     s          *(1.+0.61*yq(i,k))
+            enddo
+         enddo
+         do i=1,ngrid
+            yzlev(i,1)=0.
+            yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1)
+         enddo
+         do k=2,klev
+            do i=1,ngrid
+               yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+            enddo
+         enddo
+
+
+cIM cf FH   yustar(:) =SQRT(ycoefm(:,1)*(yu(:,1)*yu(:,1)+yv(:,1)*yv(:,1)))
+      yustar(1:ngrid) =SQRT(ycoefm(1:ngrid,1)*
+     $       (yu(1:ngrid,1)*yu(1:ngrid,1)+yv(1:ngrid,1)*yv(1:ngrid,1)))
+
+c  Fin de la partie qui doit etre unclue a terme dans clmain.
+
+Cette routine est ecrite pour avoir en entree ustar, teta et zlev
+c  Ici, on a inclut le calcul de ces trois variables dans la routine
+c  coefkzmin en attendant une nouvelle version de la couche limite
+c  ou ces variables seront disponibles.
+
+c Debut de la routine coefkzmin proprement dite.
+
+      ustar=yustar
+      teta=yteta
+      zlev=yzlev
+
+      do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+      enddo
+      
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=0. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            kn(ig,k)=kmin
+            km(ig,k)=kmin
+         enddo
+      enddo
+
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/comgeomphy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/comgeomphy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/comgeomphy.F90	(revision 984)
@@ -0,0 +1,23 @@
+module comgeomphy
+   real,save,allocatable :: airephy(:)
+   real,save,allocatable :: cuphy(:)
+   real,save,allocatable :: cvphy(:)
+   real,save,allocatable :: rlatd(:)
+   real,save,allocatable :: rlond(:)
+!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond)
+contains
+  
+  subroutine InitComgeomphy
+  USE mod_phys_lmdz_para
+  implicit none
+    
+ 
+    allocate(airephy(klon_omp))
+    allocate(cuphy(klon_omp))
+    allocate(cvphy(klon_omp))
+    allocate(rlatd(klon_omp))
+    allocate(rlond(klon_omp))
+
+  end subroutine InitComgeomphy
+  
+end module comgeomphy
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/comgeomphy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/comgeomphy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/comgeomphy.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+c
+c
+c Common de passage de la geometrie de la dynamique a la physique
+      real airephy(klon),cuphy(klon),cvphy(klon)
+      REAL rlatd(klon), rlond(klon)
+      common/comgeomphy/airephy,cuphy,cvphy,rlatd, rlond
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/compbl.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/compbl.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/compbl.h	(revision 984)
@@ -0,0 +1,6 @@
+      !
+      ! $Header$
+      !
+      integer iflag_pbl
+      common/compbl/iflag_pbl
+!$OMP THREADPRIVATE(/compbl/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conccm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conccm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conccm.F	(revision 984)
@@ -0,0 +1,835 @@
+!
+! $Header$
+!
+      SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q,
+     s                   d_t, d_q, rain, snow, kbascm, ktopcm)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996
+c Objet: Schema simple (avec flux de masse) pour la convection 
+c        (schema standard du modele NCAR CCM2)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Entree:
+      REAL dtime              ! pas d'integration
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (g/g)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c Sortie:
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation vapeur
+      REAL rain(klon)         ! pluie (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER kbascm(klon)    ! niveau du bas de convection
+      INTEGER ktopcm(klon)    ! niveau du haut de convection
+c
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pres(klon,klev)
+      REAL dp(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL cmfprs(klon)
+      REAL cmfprt(klon)
+      INTEGER ntop(klon)
+      INTEGER nbas(klon)
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql_bis(klon,klev)
+      REAL rneb_bis(klon,klev)
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kbascm(i) = 0
+         ktopcm(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         pres(i,k) = pplay(i,klev-k+1)
+         dp(i,k) = paprs(i,klev+1-k)-paprs(i,klev+1-k+1)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                      * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgeom(i,klev+1-k) = zgeom(i,klev+1-k+1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+      CALL cmfmca(dtime, pres, dp, zgeom, pt, pq,
+     $                  cmfprt, cmfprs, ntop, nbas)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = pq(i,k) - q(i,klev+1-k) 
+         d_t(i,klev+1-k) = pt(i,k) - t(i,klev+1-k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         rain(i) = cmfprt(i) * rhoh2o
+         snow(i) = cmfprs(i) * rhoh2o
+         kbascm(i) = klev+1 - nbas(i)
+         ktopcm(i) = klev+1 - ntop(i)
+      ENDDO
+c
+      IF (usekuo) THEN
+      CALL conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s            d_t_bis, d_q_bis, d_ql_bis, rneb_bis,
+     s            rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         kbascm(i) = MIN(kbascm(i),ibas_bis(i))
+         ktopcm(i) = MAX(ktopcm(i),itop_bis(i))
+      ENDDO
+      DO k = 1, klev ! eau liquide convective est
+      DO i = 1, klon ! dispersee dans l'air
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql_bis(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE cmfmca(deltat, p, dp, gz,
+     $                  tb, shb,
+     $                  cmfprt, cmfprs, cnt, cnb)
+      USE dimphy
+      IMPLICIT none
+C-----------------------------------------------------------------------
+C Moist convective mass flux procedure:
+C If stratification is unstable to nonentraining parcel ascent,
+C complete an adjustment making use of a simple cloud model
+C 
+C Code generalized to allow specification of parcel ("updraft")
+C properties, as well as convective transport of an arbitrary
+C number of passive constituents (see cmrb array).
+C----------------------------Code History-------------------------------
+C Original version:  J. J. Hack, March 22, 1990
+C Standardized:      J. Rosinski, June 1992
+C Reviewed:          J. Hack, G. Taylor, August 1992
+c Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994,
+c                    J. Geophys. Res. vol 99, D3, 5551-5568). J'ai
+c                    introduit les constantes et les fonctions thermo-
+c                    dynamiques du Centre Europeen. J'ai elimine le
+c                    re-indicage du code en esperant que cela pourra
+c                    simplifier la lecture et la comprehension.
+C-----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      INTEGER pcnst ! nombre de traceurs passifs
+      PARAMETER (pcnst=1)
+C------------------------------Arguments--------------------------------
+C Input arguments
+C
+      REAL deltat                 ! time step (seconds)
+      REAL p(klon,klev)           ! pressure
+      REAL dp(klon,klev)          ! delta-p
+      REAL gz(klon,klev)          ! geopotential (a partir du sol)
+c
+      REAL thtap(klon)            ! PBL perturbation theta
+      REAL shp(klon)              ! PBL perturbation specific humidity 
+      REAL pblh(klon)             ! PBL height (provided by PBL routine)
+      REAL cmrp(klon,pcnst)       ! constituent perturbations in PBL
+c
+c Updated arguments:
+c
+      REAL tb(klon,klev)         ! temperature (t bar)
+      REAL shb(klon,klev)        ! specific humidity (sh bar)
+      REAL cmrb(klon,klev,pcnst) ! constituent mixing ratios (cmr bar)
+C
+C Output arguments
+C
+      REAL cmfdt(klon,klev)    ! dT/dt due to moist convection
+      REAL cmfdq(klon,klev)    ! dq/dt due to moist convection
+      REAL cmfmc(klon,klev )   ! moist convection cloud mass flux
+      REAL cmfdqr(klon,klev)   ! dq/dt due to convective rainout 
+      REAL cmfsl(klon,klev )   ! convective lw static energy flux
+      REAL cmflq(klon,klev )   ! convective total water flux
+      REAL cmfprt(klon)        ! convective precipitation rate
+      REAL cmfprs(klon)        ! convective snowfall rate
+      REAL qc(klon,klev)       ! dq/dt due to rainout terms
+      INTEGER cnt(klon)        ! top level of convective activity   
+      INTEGER cnb(klon)        ! bottom level of convective activity
+C------------------------------Parameters-------------------------------
+      REAL c0         ! rain water autoconversion coefficient
+      PARAMETER (c0=1.0e-4)
+      REAL dzmin       ! minimum convective depth for precipitation
+      PARAMETER (dzmin=0.0)
+      REAL betamn      ! minimum overshoot parameter
+      PARAMETER (betamn=0.10)
+      REAL cmftau      ! characteristic adjustment time scale
+      PARAMETER (cmftau=3600.)
+      INTEGER limcnv   ! top interface level limit for convection
+      PARAMETER (limcnv=1)
+      REAL tpmax       ! maximum acceptable t perturbation (degrees C)
+      PARAMETER (tpmax=1.50)
+      REAL shpmax      ! maximum acceptable q perturbation (g/g)
+      PARAMETER (shpmax=1.50e-3)
+      REAL tiny        ! arbitrary small num used in transport estimates
+      PARAMETER (tiny=1.0e-36)
+      REAL eps         ! convergence criteria (machine dependent)
+      PARAMETER (eps=1.0e-13)
+      REAL tmelt       ! freezing point of water(req'd for rain vs snow)
+      PARAMETER (tmelt=273.15)
+      REAL ssfac ! supersaturation bound (detrained air)
+      PARAMETER (ssfac=1.001)
+C
+C---------------------------Local workspace-----------------------------
+      REAL gam(klon,klev)     ! L/cp (d(qsat)/dT)
+      REAL sb(klon,klev)      ! dry static energy (s bar)
+      REAL hb(klon,klev)      ! moist static energy (h bar)
+      REAL shbs(klon,klev)    ! sat. specific humidity (sh bar star)
+      REAL hbs(klon,klev)     ! sat. moist static energy (h bar star)
+      REAL shbh(klon,klev+1)  ! specific humidity on interfaces
+      REAL sbh(klon,klev+1)   ! s bar on interfaces
+      REAL hbh(klon,klev+1)   ! h bar on interfaces
+      REAL cmrh(klon,klev+1)  ! interface constituent mixing ratio 
+      REAL prec(klon)         ! instantaneous total precipitation
+      REAL dzcld(klon)        ! depth of convective layer (m)
+      REAL beta(klon)         ! overshoot parameter (fraction)
+      REAL betamx             ! local maximum on overshoot
+      REAL eta(klon)          ! convective mass flux (kg/m^2 s)
+      REAL etagdt             ! eta*grav*deltat
+      REAL cldwtr(klon)       ! cloud water (mass)
+      REAL rnwtr(klon)        ! rain water  (mass)
+      REAL sc  (klon)         ! dry static energy   ("in-cloud")
+      REAL shc (klon)         ! specific humidity   ("in-cloud")
+      REAL hc  (klon)         ! moist static energy ("in-cloud")
+      REAL cmrc(klon)         ! constituent mix rat ("in-cloud")
+      REAL dq1(klon)          ! shb  convective change (lower lvl)
+      REAL dq2(klon)          ! shb  convective change (mid level)
+      REAL dq3(klon)          ! shb  convective change (upper lvl)
+      REAL ds1(klon)          ! sb   convective change (lower lvl)
+      REAL ds2(klon)          ! sb   convective change (mid level)
+      REAL ds3(klon)          ! sb   convective change (upper lvl)
+      REAL dcmr1(klon)        ! cmrb convective change (lower lvl)
+      REAL dcmr2(klon)        ! cmrb convective change (mid level)
+      REAL dcmr3(klon)        ! cmrb convective change (upper lvl)
+      REAL flotab(klon)       ! hc - hbs (mesure d'instabilite)
+      LOGICAL ldcum(klon)     ! .true. si la convection existe
+      LOGICAL etagt0          ! true if eta > 0.0
+      REAL dt                 ! current 2 delta-t (model time step)
+      REAL cats     ! modified characteristic adj. time
+      REAL rdt      ! 1./dt
+      REAL qprime   ! modified specific humidity pert.
+      REAL tprime   ! modified thermal perturbation
+      REAL pblhgt   ! bounded pbl height (max[pblh,1m])
+      REAL fac1     ! intermediate scratch variable
+      REAL shprme   ! intermediate specific humidity pert.
+      REAL qsattp   ! saturation mixing ratio for 
+C                   !  thermally perturbed PBL parcels 
+      REAL dz       ! local layer depth
+      REAL b1       ! bouyancy measure in detrainment lvl
+      REAL b2       ! bouyancy measure in condensation lvl
+      REAL g     ! bounded vertical gradient of hb
+      REAL tmass ! total mass available for convective exchange
+      REAL denom ! intermediate scratch variable
+      REAL qtest1! used in negative q test (middle lvl) 
+      REAL qtest2! used in negative q test (lower lvl) 
+      REAL fslkp ! flux lw static energy (bot interface)
+      REAL fslkm ! flux lw static energy (top interface)
+      REAL fqlkp ! flux total water (bottom interface)
+      REAL fqlkm ! flux total water (top interface)
+      REAL botflx! bottom constituent mixing ratio flux
+      REAL topflx! top constituent mixing ratio flux
+      REAL efac1 ! ratio cmrb to convectively induced change (bot lvl)
+      REAL efac2 ! ratio cmrb to convectively induced change (mid lvl)
+      REAL efac3 ! ratio cmrb to convectively induced change (top lvl)
+c
+      INTEGER i,k  ! indices horizontal et vertical
+      INTEGER km1  ! k-1 (index offset)
+      INTEGER kp1  ! k+1 (index offset)
+      INTEGER m    ! constituent index
+      INTEGER ktp  ! temporary index used to track top 
+      INTEGER is   ! nombre de points a ajuster
+C
+      REAL tmp1, tmp2, tmp3, tmp4
+      REAL zx_t, zx_p, zx_q, zx_qs, zx_gam
+      REAL zcor, zdelta, zcvm5
+C
+      REAL qhalf, sh1, sh2, shbs1, shbs2
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      qhalf(sh1,sh2,shbs1,shbs2) = MIN(MAX(sh1,sh2),
+     $                            (shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2))
+C
+C-----------------------------------------------------------------------
+c pas de traceur pour l'instant
+      DO m = 1, pcnst
+      DO k = 1, klev
+      DO i = 1, klon
+         cmrb(i,k,m) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+c
+c Les perturbations de la couche limite sont zero pour l'instant
+c
+      DO m = 1, pcnst
+      DO i = 1, klon
+         cmrp(i,m) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         thtap(i) = 0.0
+         shp(i) = 0.0
+         pblh(i) = 1.0
+      ENDDO
+C
+C Ensure that characteristic adjustment time scale (cmftau) assumed
+C in estimate of eta isn't smaller than model time scale (deltat)
+C
+      dt   = deltat
+      cats = MAX(dt,cmftau)
+      rdt  = 1.0/dt
+C
+C Compute sb,hb,shbs,hbs
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = tb(i,k)
+         zx_p = p(i,k)
+         zx_q = shb(i,k)
+           zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+           zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+           zx_qs=MIN(0.5,zx_qs)
+           zcor=1./(1.-retv*zx_qs)
+           zx_qs=zx_qs*zcor
+           zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+         shbs(i,k) = zx_qs
+         gam(i,k) = zx_gam
+      ENDDO
+      ENDDO
+C
+      DO k=limcnv,klev
+         DO i=1,klon
+            sb (i,k) = RCPD*tb(i,k) + gz(i,k)
+            hb (i,k) = sb(i,k) + RLVTT*shb(i,k)
+            hbs(i,k) = sb(i,k) + RLVTT*shbs(i,k)
+         ENDDO
+      ENDDO
+C
+C Compute sbh, shbh
+C
+      DO k=limcnv+1,klev
+         km1 = k - 1
+         DO i=1,klon
+            sbh (i,k) =0.5*(sb(i,km1) + sb(i,k))
+            shbh(i,k) =qhalf(shb(i,km1),shb(i,k),shbs(i,km1),shbs(i,k))
+            hbh (i,k) =sbh(i,k) + RLVTT*shbh(i,k)
+         ENDDO
+      ENDDO
+C
+C Specify properties at top of model (not used, but filling anyway)
+C
+      DO i=1,klon
+         sbh (i,limcnv) = sb(i,limcnv)
+         shbh(i,limcnv) = shb(i,limcnv)
+         hbh (i,limcnv) = hb(i,limcnv)
+      ENDDO
+C
+C Zero vertically independent control, tendency & diagnostic arrays
+C
+      DO i=1,klon
+         prec(i)  = 0.0
+         dzcld(i) = 0.0
+         cnb(i)   = 0
+         cnt(i)   = klev+1
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1,klon
+         cmfdt(i,k)  = 0.
+         cmfdq(i,k)  = 0.
+         cmfdqr(i,k) = 0.
+         cmfmc(i,k)  = 0.
+         cmfsl(i,k)  = 0.
+         cmflq(i,k)  = 0.
+        ENDDO
+      ENDDO
+C
+C Begin moist convective mass flux adjustment procedure.
+C Formalism ensures that negative cloud liquid water can never occur
+C
+      DO 70 k=klev-1,limcnv+1,-1
+         km1 = k - 1
+         kp1 = k + 1
+         DO 10 i=1,klon
+            eta   (i) = 0.0
+            beta  (i) = 0.0
+            ds1   (i) = 0.0
+            ds2   (i) = 0.0
+            ds3   (i) = 0.0
+            dq1   (i) = 0.0
+            dq2   (i) = 0.0
+            dq3   (i) = 0.0
+C
+C Specification of "cloud base" conditions
+C
+            qprime    = 0.0
+            tprime    = 0.0
+C
+C Assign tprime within the PBL to be proportional to the quantity
+C thtap (which will be bounded by tpmax), passed to this routine by 
+C the PBL routine.  Don't allow perturbation to produce a dry 
+C adiabatically unstable parcel.  Assign qprime within the PBL to be 
+C an appropriately modified value of the quantity shp (which will be 
+C bounded by shpmax) passed to this routine by the PBL routine.  The 
+C quantity qprime should be less than the local saturation value 
+C (qsattp=qsat[t+tprime,p]).  In both cases, thtap and shp are
+C linearly reduced toward zero as the PBL top is approached.
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.0) THEN
+               fac1   = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               tprime = MIN(thtap(i),tpmax)*fac1
+               qsattp = shbs(i,kp1) + RCPD/RLVTT*gam(i,kp1)*tprime
+               shprme = MIN(MIN(shp(i),shpmax)*fac1,
+     $                        MAX(qsattp-shb(i,kp1),0.0))
+               qprime = MAX(qprime,shprme)
+            ELSE
+               tprime = 0.0
+               qprime = 0.0
+            ENDIF
+C
+C Specify "updraft" (in-cloud) thermodynamic properties
+C
+            sc (i)    = sb (i,kp1) + RCPD*tprime
+            shc(i)    = shb(i,kp1) + qprime
+            hc (i)    = sc (i    ) + RLVTT*shc(i)
+            flotab(i) = hc(i) - hbs(i,k)
+            dz        = dp(i,k)*RD*tb(i,k)/RG/p(i,k)
+            IF (flotab(i).gt.0.0) THEN
+               dzcld(i) = dzcld(i) + dz
+            ELSE
+               dzcld(i) = 0.0
+            ENDIF
+   10    CONTINUE
+C
+C Check on moist convective instability
+C
+         is = 0
+         DO i = 1, klon
+            IF (flotab(i).GT.0.0) THEN
+               ldcum(i) = .TRUE.
+               is = is + 1
+            ELSE
+               ldcum(i) = .FALSE.
+            ENDIF
+         ENDDO
+C
+         IF (is.EQ.0) THEN
+            DO i=1,klon
+               dzcld(i) = 0.0
+            ENDDO
+            GOTO 70
+         ENDIF
+C
+C Current level just below top level => no overshoot
+C
+         IF (k.le.limcnv+1) THEN
+            DO i=1,klon
+            IF (ldcum(i)) THEN
+               cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+               cldwtr(i) = MAX(0.0,cldwtr(i))
+               beta(i)   = 0.0
+            ENDIF
+            ENDDO
+            GOTO 20
+         ENDIF
+C
+C First guess at overshoot parameter using crude buoyancy closure
+C 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
+C If pre-existing supersaturation in detrainment layer, beta=0
+C cldwtr is temporarily equal to RLVTT*l (l=> liquid water)
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+            cldwtr(i) = MAX(0.0,cldwtr(i))
+            betamx = 1.0 - c0*MAX(0.0,(dzcld(i)-dzmin))
+            b1        = (hc(i) - hbs(i,km1))*dp(i,km1)
+            b2        = (hc(i) - hbs(i,k  ))*dp(i,k  )
+            beta(i)   = MAX(betamn,MIN(betamx, 1.0+b1/b2))
+            IF (hbs(i,km1).le.hb(i,km1)) beta(i) = 0.0
+         ENDIF
+         ENDDO
+C
+C Bound maximum beta to ensure physically realistic solutions
+C
+C First check constrains beta so that eta remains positive
+C (assuming that eta is already positive for beta equal zero)
+c La premiere contrainte de beta est que le flux eta doit etre positif.
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.99*(tmp1/tmp2)
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+C
+C Second check involves supersaturation of "detrainment layer"
+C small amount of supersaturation acceptable (by ssfac factor)
+c La 2e contrainte est que la convection ne doit pas sursaturer
+c la "detrainment layer", Neanmoins, une petite sursaturation
+c est acceptee (facteur ssfac).
+C
+            IF (hb(i,km1).lt.hbs(i,km1)) THEN
+               tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $               - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+               tmp1 = tmp1/dp(i,k)
+               tmp2 = gam(i,km1)*(sbh(i,k)-sc(i) + cldwtr(i)) -
+     $                 hbh(i,k) + hc(i) - sc(i) + sbh(i,k)
+               tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+               tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2
+     $               / (dp(i,km1)*(hbs(i,km1)-hb(i,km1))) + tmp3
+               IF ((beta(i)*tmp4-tmp1).GT.0.0) THEN
+                  betamx = ssfac*(tmp1/tmp4)
+                  beta(i)   = MAX(0.0,MIN(betamx,beta(i)))
+               ENDIF
+            ELSE 
+               beta(i) = 0.0
+            ENDIF
+C
+C Third check to avoid introducing 2 delta x thermodynamic
+C noise in the vertical ... constrain adjusted h (or theta e)
+C so that the adjustment doesn't contribute to "kinks" in h
+C
+            g = MIN(0.0,hb(i,k)-hb(i,km1))
+            tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt) / (hc(i)-hbs(i,k))
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp1 = tmp1/dp(i,k)
+            tmp1 = tmp3*tmp1 + (hc(i) - hbh(i,kp1))/dp(i,k)
+            tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+     $            + (hc(i)-hbh(i,k)-cldwtr(i))
+     $             *(1.0/dp(i,k)+1.0/dp(i,kp1))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.0
+               IF (tmp2.NE.0.0) betamx = tmp1/tmp2
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C Calculate mass flux required for stabilization.
+C
+C Ensure that the convective mass flux, eta, is positive by
+C setting negative values of eta to zero..
+C Ensure that estimated mass flux cannot move more than the
+C minimum of total mass contained in either layer k or layer k+1.
+C Also test for other pathological cases that result in non-
+C physical states and adjust eta accordingly.
+C
+   20    CONTINUE
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            beta(i) = MAX(0.0,beta(i))
+            tmp1 = hc(i) - hbs(i,k)
+            tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) -
+     $               beta(i)*(1.0+gam(i,k))*(sc(i)-sbh(i,k)))/dp(i,k) -
+     $              (hbh(i,kp1)-hc(i))/dp(i,kp1)
+            eta(i) = tmp1/(tmp2*RG*cats)
+            tmass = MIN(dp(i,k),dp(i,kp1))/RG
+            IF (eta(i).GT.tmass*rdt .OR. eta(i).LE.0.0) eta(i) = 0.0
+C
+C Check on negative q in top layer (bound beta)
+C
+            IF(shc(i)-shbh(i,k).LT.0.0 .AND. beta(i)*eta(i).NE.0.0)THEN
+               denom = eta(i)*RG*dt*(shc(i) - shbh(i,k))/dp(i,km1)
+               beta(i) = MAX(0.0,MIN(-0.999*shb(i,km1)/denom,beta(i)))
+            ENDIF
+C
+C Check on negative q in middle layer (zero eta)
+C
+            qtest1 = shb(i,k) + eta(i)*RG*dt*((shc(i) - shbh(i,kp1)) -
+     $               (1.0 - beta(i))*cldwtr(i)/RLVTT -
+     $               beta(i)*(shc(i) - shbh(i,k)))/dp(i,k)
+            IF (qtest1.le.0.0) eta(i) = 0.0
+C
+C Check on negative q in lower layer (bound eta)
+C
+            fac1 = -(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            qtest2 = shb(i,kp1) - eta(i)*RG*dt*fac1
+            IF (qtest2 .lt. 0.0) THEN
+               eta(i) = 0.99*shb(i,kp1)/(RG*dt*fac1)
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C
+C Calculate cloud water, rain water, and thermodynamic changes
+C
+         DO 30 i=1,klon
+         IF (ldcum(i)) THEN
+            etagdt = eta(i)*RG*dt
+            cldwtr(i) = etagdt*cldwtr(i)/RLVTT/RG
+            rnwtr(i) = (1.0 - beta(i))*cldwtr(i)
+            ds1(i) = etagdt*(sbh(i,kp1) - sc(i))/dp(i,kp1)
+            dq1(i) = etagdt*(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            ds2(i) = (etagdt*(sc(i) - sbh(i,kp1)) +
+     $                RLVTT*RG*cldwtr(i) - beta(i)*etagdt*
+     $                (sc(i) - sbh(i,k)))/dp(i,k)
+            dq2(i) = (etagdt*(shc(i) - shbh(i,kp1)) -
+     $                RG*rnwtr(i) - beta(i)*etagdt*
+     $                (shc(i) - shbh(i,k)))/dp(i,k)
+            ds3(i) = beta(i)*(etagdt*(sc(i) - sbh(i,k)) -
+     $               RLVTT*RG*cldwtr(i))/dp(i,km1)
+            dq3(i) = beta(i)*etagdt*(shc(i) - shbh(i,k))/dp(i,km1)
+C
+C Isolate convective fluxes for later diagnostics
+C
+            fslkp = eta(i)*(sc(i) - sbh(i,kp1))
+            fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) -
+     $                       RLVTT*cldwtr(i)*rdt)
+            fqlkp = eta(i)*(shc(i) - shbh(i,kp1))
+            fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k))
+C
+C
+C Update thermodynamic profile (update sb, hb, & hbs later)
+C
+            tb (i,kp1) = tb(i,kp1)  + ds1(i) / RCPD
+            tb (i,k  ) = tb(i,k  )  + ds2(i) / RCPD
+            tb (i,km1) = tb(i,km1)  + ds3(i) / RCPD
+            shb(i,kp1) = shb(i,kp1) + dq1(i)
+            shb(i,k  ) = shb(i,k  ) + dq2(i)
+            shb(i,km1) = shb(i,km1) + dq3(i)
+            prec(i)    = prec(i)    + rnwtr(i)/rhoh2o
+C
+C Update diagnostic information for final budget
+C Tracking temperature & specific humidity tendencies,
+C rainout term, convective mass flux, convective liquid
+C water static energy flux, and convective total water flux
+C
+            cmfdt (i,kp1) = cmfdt (i,kp1) + ds1(i)/RCPD*rdt
+            cmfdt (i,k  ) = cmfdt (i,k  ) + ds2(i)/RCPD*rdt
+            cmfdt (i,km1) = cmfdt (i,km1) + ds3(i)/RCPD*rdt
+            cmfdq (i,kp1) = cmfdq (i,kp1) + dq1(i)*rdt
+            cmfdq (i,k  ) = cmfdq (i,k  ) + dq2(i)*rdt
+            cmfdq (i,km1) = cmfdq (i,km1) + dq3(i)*rdt
+            cmfdqr(i,k  ) = cmfdqr(i,k  ) + (RG*rnwtr(i)/dp(i,k))*rdt
+            cmfmc (i,kp1) = cmfmc (i,kp1) + eta(i)
+            cmfmc (i,k  ) = cmfmc (i,k  ) + beta(i)*eta(i)
+            cmfsl (i,kp1) = cmfsl (i,kp1) + fslkp
+            cmfsl (i,k  ) = cmfsl (i,k  ) + fslkm
+            cmflq (i,kp1) = cmflq (i,kp1) + RLVTT*fqlkp
+            cmflq (i,k  ) = cmflq (i,k  ) + RLVTT*fqlkm
+            qc    (i,k  ) =                (RG*rnwtr(i)/dp(i,k))*rdt
+         ENDIF
+   30    CONTINUE
+C
+C Next, convectively modify passive constituents
+C
+         DO 50 m=1,pcnst
+         DO 40 i=1,klon
+         IF (ldcum(i)) THEN
+C
+C If any of the reported values of the constituent is negative in
+C the three adjacent levels, nothing will be done to the profile
+C
+            IF ((cmrb(i,kp1,m).LT.0.0) .OR.
+     $          (cmrb(i,k,m).LT.0.0) .OR.
+     $          (cmrb(i,km1,m).LT.0.0)) GOTO 40
+C
+C Specify constituent interface values (linear interpolation)
+C
+            cmrh(i,k  ) = 0.5*(cmrb(i,km1,m) + cmrb(i,k  ,m))
+            cmrh(i,kp1) = 0.5*(cmrb(i,k  ,m) + cmrb(i,kp1,m))
+C
+C Specify perturbation properties of constituents in PBL
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.) THEN
+               fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               cmrc(i) = cmrb(i,kp1,m) + cmrp(i,m)*fac1
+            ELSE
+               cmrc(i) = cmrb(i,kp1,m)
+            ENDIF
+C
+C Determine fluxes, flux divergence => changes due to convection
+C Logic must be included to avoid producing negative values. A bit
+C messy since there are no a priori assumptions about profiles.
+C Tendency is modified (reduced) when pending disaster detected.
+C
+            etagdt = eta(i)*RG*dt
+            botflx   = etagdt*(cmrc(i) - cmrh(i,kp1))
+            topflx   = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
+            dcmr1(i) = -botflx/dp(i,kp1)
+            efac1    = 1.0
+            efac2    = 1.0
+            efac3    = 1.0
+C
+            IF (cmrb(i,kp1,m)+dcmr1(i) .LT. 0.0) THEN
+               efac1 = MAX(tiny,ABS(cmrb(i,kp1,m)/dcmr1(i)) - eps)
+            ENDIF
+C
+            IF (efac1.EQ.tiny .OR. efac1.GT.1.0) efac1 = 0.0
+            dcmr1(i) = -efac1*botflx/dp(i,kp1)
+            dcmr2(i) = (efac1*botflx - topflx)/dp(i,k)
+C  
+            IF (cmrb(i,k,m)+dcmr2(i) .LT. 0.0) THEN
+               efac2 = MAX(tiny,ABS(cmrb(i,k  ,m)/dcmr2(i)) - eps)
+            ENDIF
+C
+            IF (efac2.EQ.tiny .OR. efac2.GT.1.0) efac2 = 0.0
+            dcmr2(i) = (efac1*botflx - efac2*topflx)/dp(i,k)
+            dcmr3(i) = efac2*topflx/dp(i,km1)
+C
+            IF (cmrb(i,km1,m)+dcmr3(i) .LT. 0.0) THEN
+               efac3 = MAX(tiny,ABS(cmrb(i,km1,m)/dcmr3(i)) - eps)
+            ENDIF
+C
+            IF (efac3.EQ.tiny .OR. efac3.GT.1.0) efac3 = 0.0
+            efac3    = MIN(efac2,efac3)
+            dcmr2(i) = (efac1*botflx - efac3*topflx)/dp(i,k)
+            dcmr3(i) = efac3*topflx/dp(i,km1)
+C
+            cmrb(i,kp1,m) = cmrb(i,kp1,m) + dcmr1(i)
+            cmrb(i,k  ,m) = cmrb(i,k  ,m) + dcmr2(i)
+            cmrb(i,km1,m) = cmrb(i,km1,m) + dcmr3(i)
+         ENDIF
+   40    CONTINUE
+   50    CONTINUE              ! end of m=1,pcnst loop
+C
+         IF (k.EQ.limcnv+1) GOTO 60 ! on ne pourra plus glisser
+c
+c Dans la procedure de glissage ascendant, les variables thermo-
+c dynamiques des couches k et km1 servent au calcul des couches
+c superieures. Elles ont donc besoin d'une mise-a-jour.
+C
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            zx_t = tb(i,k)
+            zx_p = p(i,k)
+            zx_q = shb(i,k)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,k) = zx_qs
+            gam(i,k) = zx_gam
+c
+            zx_t = tb(i,km1)
+            zx_p = p(i,km1)
+            zx_q = shb(i,km1)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,km1) = zx_qs
+            gam(i,km1) = zx_gam
+C
+            sb (i,k  ) = sb(i,k  ) + ds2(i)
+            sb (i,km1) = sb(i,km1) + ds3(i)
+            hb (i,k  ) = sb(i,k  ) + RLVTT*shb(i,k)
+            hb (i,km1) = sb(i,km1) + RLVTT*shb(i,km1)
+            hbs(i,k  ) = sb(i,k  ) + RLVTT*shbs(i,k  )
+            hbs(i,km1) = sb(i,km1) + RLVTT*shbs(i,km1)
+C
+            sbh (i,k) = 0.5*(sb(i,k) + sb(i,km1))
+            shbh(i,k) = qhalf(shb(i,km1),shb(i,k)
+     $                       ,shbs(i,km1),shbs(i,k))
+            hbh (i,k) = sbh(i,k) + RLVTT*shbh(i,k)
+            sbh (i,km1) = 0.5*(sb(i,km1) + sb(i,k-2))
+            shbh(i,km1) = qhalf(shb(i,k-2),shb(i,km1),
+     $                    shbs(i,k-2),shbs(i,km1))
+            hbh (i,km1) = sbh(i,km1) + RLVTT*shbh(i,km1)
+         ENDIF
+         ENDDO
+C
+C Ensure that dzcld is reset if convective mass flux zero
+C specify the current vertical extent of the convective activity
+C top of convective layer determined by size of overshoot param.
+C
+   60    CONTINUE
+         DO i=1,klon
+            etagt0 = eta(i).gt.0.0
+            IF (.not.etagt0) dzcld(i) = 0.0
+            IF (etagt0 .and. beta(i).gt.betamn) THEN
+               ktp = km1
+            ELSE
+               ktp = k
+            ENDIF
+            IF (etagt0) THEN
+               cnt(i) = MIN(cnt(i),ktp)
+               cnb(i) = MAX(cnb(i),k)
+            ENDIF
+         ENDDO
+   70 CONTINUE        ! end of k loop
+C
+C determine whether precipitation, prec, is frozen (snow) or not
+C
+      DO i=1,klon
+         IF (tb(i,klev).LT.tmelt .AND. tb(i,klev-1).lt.tmelt) THEN
+             cmfprs(i) = prec(i)*rdt
+         ELSE
+             cmfprt(i) = prec(i)*rdt
+         ENDIF
+      ENDDO
+C
+      RETURN  ! we're all done ... return to calling procedure
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/concvl.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/concvl.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/concvl.F	(revision 984)
@@ -0,0 +1,198 @@
+!
+! $Header$
+!
+      SUBROUTINE concvl (iflag_con,dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcondc,wd,
+     .             pmflxr,pmflxs,
+     .             da,phi,mp)
+ 
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Cape----output-R-CAPE (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       INTEGER iflag_con
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev)
+       REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev),cape(klon),tvp(klon,klev)
+       real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+       REAL qcondc(klon,klev)
+       REAL wd(klon)
+c
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev)
+cym       REAL cbmf(klon)
+cym       SAVE cbmf
+       REAL,ALLOCATABLE,SAVE :: cbmf(:)
+c$OMP THREADPRIVATE(cbmf)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c
+cym
+      snow(:)=0
+      
+      IF (ifrst .EQ. 0) THEN
+         ifrst = 1
+	 allocate(cbmf(klon))
+         DO i = 1, klon
+          cbmf(i) = 0.
+         ENDDO
+      ENDIF
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+         pmflxs(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+
+c
+      if (iflag_con .eq. 4) then
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+      else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs(i,k)=zx_qs
+        ENDDO
+      ENDDO
+      endif ! iflag_con
+c
+C------------------------------------------------------------------
+
+C Main driver for convection:
+C		iflag_con = 3  -> equivalent to convect3
+C		iflag_con = 4  -> equivalent to convect1/2
+
+      CALL cv_driver(klon,klev,klev+1,ntra,iflag_con,
+     :              t,q,qs,u,v,tra,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,d_tra,rain,
+     $              pmflxr,cbmf,work1,work2,
+     $              kbas,ktop,
+     $              dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape,
+     $              da,phi,mp)
+
+C------------------------------------------------------------------
+
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+      ENDDO
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO
+c les traceurs ne sont pas mis dans cette version de convect4:
+      if (iflag_con.eq.4) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+         ENDDO
+        ENDDO
+       ENDDO
+      endif
+ 
+      RETURN
+      END
+ 
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/condsurf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/condsurf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/condsurf.F	(revision 984)
@@ -0,0 +1,139 @@
+c $Header$
+c
+      SUBROUTINE condsurf( jour, jourvrai, lmt_bils )
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+c
+c I. Musat 05.2005
+c
+c Lire chaque jour le bilan de chaleur au sol issu 
+c d'un run atmospherique afin de l'utiliser dans
+c dans un run "slab" ocean 
+c -----------------------------------------
+c jour     : input  , numero du jour a lire
+c jourvrai : input  , vrai jour de la simulation  
+c
+c lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean")
+c
+#include "netcdf.inc"
+      INTEGER nid, nvarid
+      INTEGER debut(2)
+      INTEGER epais(2)
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+#include "temps.h"
+#include "clesphys.h"
+c
+      INTEGER     nannemax
+      PARAMETER ( nannemax = 60 )
+c
+      INTEGER jour, jourvrai
+      REAL lmt_bils(klon) !bilan chaleur au sol
+c
+c Variables locales:
+      INTEGER ig, i, kt, ierr
+      LOGICAL ok
+      INTEGER anneelim,anneemax
+      CHARACTER*20 fich
+      
+      REAL :: lmt_bils_glo(klon_glo)
+      
+cc
+cc   .....................................................................
+cc
+cc    Pour lire le fichier limit correspondant vraiment  a l'annee de la
+cc     simulation en cours , il suffit de mettre  ok_limitvrai = .TRUE.
+cc
+cc   ......................................................................
+c
+c
+      
+      IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
+         PRINT*,'Le jour demande n est pas correct: ', jour
+         CALL ABORT
+      ENDIF
+c
+       anneelim  = annee_ref
+       anneemax  = annee_ref + nannemax
+c
+c
+       IF( ok_limitvrai )       THEN
+          DO  kt = 1, nannemax
+           IF(jourvrai.LE. (kt-1)*360 + 359  )  THEN
+              WRITE(fich,'("limit",i4,".nc")') anneelim
+c             PRINT *,' Fichier  Limite ',fich
+              GO TO 100
+             ENDIF
+           anneelim = anneelim + 1
+          ENDDO
+
+         PRINT *,' PBS ! Le jour a lire sur le fichier limit ne se '
+         PRINT *,' trouve pas sur les ',nannemax,' annees a partir de '
+         PRINT *,' l annee de debut', annee_ref
+         CALL EXIT(1)
+c
+100     CONTINUE
+c
+       ELSE
+     
+            WRITE(fich,'("limitNEW.nc")') 
+c           PRINT *,' Fichier  Limite ',fich
+       ENDIF
+c
+c Ouvrir le fichier en format NetCDF:
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        WRITE(6,*)' Pb d''ouverture du fichier ', fich
+        WRITE(6,*)' Le fichier limit ',fich,' (avec 4 chiffres , pour' 
+        WRITE(6,*)'       l an 2000 )  ,  n existe  pas !  ' 
+        WRITE(6,*)' ierr = ', ierr
+        CALL EXIT(1)
+      ENDIF
+c     DO k = 1, jour
+c La tranche de donnees a lire:
+c
+      debut(1) = 1
+      debut(2) = jourvrai
+      epais(1) = klon_glo
+      epais(2) = 1
+c Bilan flux de chaleur au sol:
+c
+      ierr = NF_INQ_VARID (nid, "BILS", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <BILS> est absent"
+         CALL abort
+      ENDIF
+      PRINT*,'debut,epais',debut,epais,'jour,jourvrai',jour,jourvrai
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_bils_glo)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_bils_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <BILS>"
+         CALL abort
+      ENDIF
+c     ENDDO !k = 1, jour
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+      
+      ENDIF ! is_mpi_root==0
+
+c$OMP END MASTER
+      CALL scatter(lmt_bils_glo,lmt_bils)
+            
+c
+c
+c     PRINT*, 'lmt_bils est lu pour jour: ', jour
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conema3.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conema3.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conema3.F	(revision 984)
@@ -0,0 +1,421 @@
+!
+! $Header$
+!
+      SUBROUTINE conema3 (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,bas,top,Ma,cape,tvp,rflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcond_incld)
+
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c Mai 1998: Interface modifiee pour implementation dans LMDZ
+c======================================================================
+c Arguments:
+c dtime---input-R-pas d'integration (s)
+c paprs---input-R-pression inter-couches (Pa)
+c pplay---input-R-pression au milieu des couches (Pa)
+c t-------input-R-temperature (K)
+c q-------input-R-humidite specifique (kg/kg)
+c u-------input-R-vitesse du vent zonal (m/s)
+c v-------input-R-vitesse duvent meridien (m/s)
+c tra-----input-R-tableau de rapport de melange des traceurs
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c
+C d_t-----output-R-increment de la temperature
+c d_q-----output-R-increment de la vapeur d'eau
+c d_u-----output-R-increment de la vitesse zonale
+c d_v-----output-R-increment de la vitesse meridienne
+c d_tra---output-R-increment du contenu en traceurs
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c kbas----output-R-bas du nuage (integer)
+c ktop----output-R-haut du nuage (integer)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c bas-----output-R-bas du nuage (real)
+c top-----output-R-haut du nuage (real)
+c Ma------output-R-flux ascendant non dilue (kg/m**2/s)
+c cape----output-R-CAPE
+c tvp-----output-R-virtual temperature of the lifted parcel
+c rflag---output-R-flag sur le fonctionnement de convect
+c pbase---output-R-pression a la base du nuage (Pa)
+c bbase---output-R-buoyancy a la base du nuage (K)
+c dtvpdt1-output-R-derivative of parcel virtual temp wrt T1 
+c dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1 
+c dplcldt-output-R-derivative of the PCP pressure wrt T1
+c dplcldr-output-R-derivative of the PCP pressure wrt Q1
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "conema3.h"
+      INTEGER i, l,m,itra
+      INTEGER ntra,ntrac !number of tracers; if no tracer transport
+                         ! is needed, set ntra = 1 (or 0)
+      PARAMETER (ntrac=nqmx-2)
+      REAL dtime
+c
+      REAL d_t2(klon,klev), d_q2(klon,klev) ! sbl
+      REAL d_u2(klon,klev), d_v2(klon,klev) ! sbl
+      REAL em_d_t2(klev), em_d_q2(klev)     ! sbl   
+      REAL em_d_u2(klev), em_d_v2(klev)     ! sbl   
+c 
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), d_t(klon,klev), d_q(klon,klev)
+      REAL u(klon,klev), v(klon,klev), tra(klon,klev,ntra)
+      REAL d_u(klon,klev), d_v(klon,klev), d_tra(klon,klev,ntra)
+      REAL work1(klon,klev), work2(klon,klev)
+      REAL upwd(klon,klev), dnwd(klon,klev), dnwdbis(klon,klev)
+      REAL rain(klon)
+      REAL snow(klon)
+      REAL cape(klon), tvp(klon,klev), rflag(klon)
+      REAL pbase(klon), bbase(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+      INTEGER kbas(klon), ktop(klon)
+
+      REAL wd(klon)
+      REAL qcond_incld(klon,klev)
+c
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+      
+cym      REAL em_t(klev)
+      REAL,ALLOCATABLE,SAVE :: em_t(:)
+c$OMP THREADPRIVATE(em_t)  
+cym      REAL em_q(klev)
+      REAL,ALLOCATABLE,SAVE :: em_q(:)
+c$OMP THREADPRIVATE(em_q) 
+cym      REAL em_qs(klev)
+      REAL,ALLOCATABLE,SAVE :: em_qs(:) 
+c$OMP THREADPRIVATE(em_qs)  
+cym      REAL em_u(klev), em_v(klev), em_tra(klev,ntrac)
+      REAL,ALLOCATABLE,SAVE :: em_u(:),em_v(:),em_tra(:,:)
+c$OMP THREADPRIVATE(em_u,em_v,em_tra)      
+cym      REAL em_ph(klev+1), em_p(klev)
+      REAL,ALLOCATABLE,SAVE ::em_ph(:),em_p(:)
+c$OMP THREADPRIVATE(em_ph,em_p)
+cym      REAL em_work1(klev), em_work2(klev)
+      REAL,ALLOCATABLE,SAVE ::em_work1(:),em_work2(:)
+c$OMP THREADPRIVATE(em_work1,em_work2)      
+cym      REAL em_precip, em_d_t(klev), em_d_q(klev)
+      REAL,SAVE :: em_precip
+c$OMP THREADPRIVATE(em_precip)      
+      REAL,ALLOCATABLE,SAVE :: em_d_t(:),em_d_q(:)
+c$OMP THREADPRIVATE(em_d_t,em_d_q)
+cym      REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac)
+      REAL,ALLOCATABLE,SAVE ::em_d_u(:),em_d_v(:),em_d_tra(:,:)
+c$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra)      
+cym      REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)
+      REAL,ALLOCATABLE,SAVE :: em_upwd(:),em_dnwd(:),em_dnwdbis(:)
+c$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis)
+      REAL em_dtvpdt1(klev), em_dtvpdq1(klev)
+      REAL em_dplcldt, em_dplcldr
+cym      SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2
+cym      SAVE em_u,em_v, em_tra
+cym      SAVE em_d_u,em_d_v, em_d_tra
+cym      SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis
+
+      INTEGER em_bas, em_top
+      SAVE em_bas, em_top
+c$OMP THREADPRIVATE(em_bas,em_top)
+      REAL em_wd
+      REAL em_qcond(klev)
+      REAL em_qcondc(klev)
+c
+      REAL zx_t, zx_qs, zdelta, zcor
+      INTEGER iflag
+      REAL sigsum
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     VARIABLES A SORTIR
+cccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+cym      REAL emmip(klev) !variation de flux ascnon dilue i et i+1
+      REAL,ALLOCATABLE,SAVE ::emmip(:)
+c$OMP THREADPRIVATE(emmip)
+cym      SAVE emmip
+cym      real emMke(klev)
+      REAL,ALLOCATABLE,SAVE ::emMke(:)
+c$OMP THREADPRIVATE(emMke)
+cym      save emMke
+      real top
+      real bas
+cym      real emMa(klev)
+      REAL,ALLOCATABLE,SAVE ::emMa(:)
+c$OMP THREADPRIVATE(emMa)
+cym      save emMa
+      real Ma(klon,klev)
+      real Ment(klev,klev)
+      real Qent(klev,klev)
+      real TPS(klev),TLS(klev)
+      real SIJ(klev,klev)
+      real em_CAPE, em_TVP(klev)
+      real em_pbase, em_bbase
+      integer iw,j,k,ix,iy
+
+c -- sb: pour schema nuages:
+
+       integer iflagcon
+       integer em_ifc(klev)
+     
+       real em_pradj
+       real em_cldf(klev), em_cldq(klev)
+       real em_ftadj(klev), em_fradj(klev)
+
+       integer ifc(klon,klev)
+       real pradj(klon)
+       real cldf(klon,klev), cldq(klon,klev)
+       real ftadj(klon,klev), fqadj(klon,klev)
+
+c sb --
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+     
+      if (first) then
+  
+        allocate(em_t(klev))
+        allocate(em_q(klev))
+        allocate(em_qs(klev))
+        allocate(em_u(klev), em_v(klev), em_tra(klev,ntrac))
+        allocate(em_ph(klev+1), em_p(klev))
+        allocate(em_work1(klev), em_work2(klev))
+        allocate(em_d_t(klev), em_d_q(klev))
+        allocate(em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac))
+        allocate(em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev))
+        allocate(emmip(klev)) 
+	allocate(emMke(klev))
+        allocate(emMa(klev))
+  
+        first=.false.
+      endif
+  
+      qcond_incld(:,:) = 0.
+c
+c@$$      print*,'debut conema'
+
+      DO 999 i = 1, klon
+      DO l = 1, klev+1
+         em_ph(l) = paprs(i,l) / 100.0
+      ENDDO
+c
+      DO l = 1, klev
+         em_p(l) = pplay(i,l) / 100.0
+         em_t(l) = t(i,l)
+         em_q(l) = q(i,l)
+         em_u(l) = u(i,l)
+         em_v(l) = v(i,l)
+         do itra = 1, ntra
+          em_tra(l,itra) = tra(i,l,itra)
+         enddo
+c@$$      print*,'em_t',em_t
+c@$$      print*,'em_q',em_q
+c@$$      print*,'em_qs',em_qs
+c@$$      print*,'em_u',em_u
+c@$$      print*,'em_v',em_v
+c@$$      print*,'em_tra',em_tra
+c@$$      print*,'em_p',em_p
+
+ 
+c
+         zx_t = em_t(l)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(l)/100.0
+         zx_qs=MIN(0.5,zx_qs)
+c@$$       print*,'zx_qs',zx_qs
+         zcor=1./(1.-retv*zx_qs) 
+         zx_qs=zx_qs*zcor
+         em_qs(l) = zx_qs
+c@$$      print*,'em_qs',em_qs
+c
+         em_work1(l) = work1(i,l)
+         em_work2(l) = work2(i,l)
+         emMke(l)=0
+c        emMa(l)=0
+c        Ma(i,l)=0
+     
+         em_dtvpdt1(l) = 0.
+         em_dtvpdq1(l) = 0.
+         dtvpdt1(i,l) = 0.
+         dtvpdq1(i,l) = 0.
+      ENDDO
+c
+      em_dplcldt = 0.
+      em_dplcldr = 0.
+      rain(i) = 0.0
+      snow(i) = 0.0
+      kbas(i) = 1
+      ktop(i) = 1
+c ajout SB:
+      bas = 1
+      top = 1
+ 
+ 
+c sb3d      write(*,1792) (em_work1(m),m=1,klev)
+1792  format('sig avant convect ',/,10(1X,E13.5))
+c
+c sb d      write(*,1793) (em_work2(m),m=1,klev)
+1793  format('w avant convect ',/,10(1X,E13.5))
+ 
+c@$$      print*,'avant convect' 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c 
+
+c     print*,'avant convect i=',i
+      CALL convect3(dtime,epmax,ok_adj_ema,
+     .              em_t, em_q, em_qs,em_u ,em_v ,
+     .              em_tra, em_p, em_ph,
+     .              klev, klev+1, klev-1,ntra, dtime, iflag,
+     .              em_d_t, em_d_q,em_d_u,em_d_v,
+     .              em_d_tra, em_precip,
+     .              em_bas, em_top,em_upwd, em_dnwd, em_dnwdbis,
+     .              em_work1, em_work2,emmip,emMke,emMa,Ment,
+     .  Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase,
+     .  em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr, ! sbl
+     .  em_d_t2,em_d_q2,em_d_u2,em_d_v2,em_wd,em_qcond,em_qcondc)!sbl
+c     print*,'apres convect '
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c -- sb: Appel schema statistique de nuages couple a la convection
+c (Bony et Emanuel 2001):
+
+c -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ:
+
+        iflagcon = 3
+c       CALL cv_thermo(iflagcon)
+
+c -- appel schema de nuages:
+
+c       CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t
+c    i          ,em_p,em_ph,dtime,em_qcondc
+c    o          ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc)
+
+        do k = 1, klev 
+         cldf(i,k)  = em_cldf(k)  ! cloud fraction (0-1)
+         cldq(i,k)  = em_cldq(k)  ! in-cloud water content (kg/kg)
+         ftadj(i,k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s)
+         fqadj(i,k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s)
+         ifc(i,k)   = em_ifc(k)   ! flag convergence clouds_gno (1 ou 2)
+        enddo
+        pradj(i) = em_pradj       ! precip from LS supersat adj (mm/day)
+
+c sb --
+c
+c SB:
+      if (iflag.ne.1 .and. iflag.ne.4) then
+         em_CAPE = 0.
+      do l = 1, klev
+         em_upwd(l) = 0.
+         em_dnwd(l) = 0.
+         em_dnwdbis(l) = 0.
+         emMa(l) = 0.
+         em_TVP(l) = 0.
+      enddo
+      endif
+c fin SB
+c
+c  If sig has been set to zero, then set Ma to zero
+c
+      sigsum = 0.
+      do k = 1,klev
+        sigsum = sigsum + em_work1(k)
+      enddo
+      if (sigsum .eq. 0.0) then
+        do k = 1,klev
+          emMa(k) = 0.
+        enddo
+      endif
+c
+c sb3d       print*,'i, iflag=',i,iflag
+c 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c       SORTIE DES ICB ET INB
+c       en fait inb et icb correspondent au niveau ou se trouve
+c       le nuage,le numero d'interface
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+c modif SB:
+      if (iflag.EQ.1 .or. iflag.EQ.4) then
+       top=em_top
+       bas=em_bas
+       kbas(i) = em_bas
+       ktop(i) = em_top
+      endif
+ 
+      pbase(i) = em_pbase
+      bbase(i) = em_bbase
+      rain(i) = em_precip/ 86400.0
+      snow(i) = 0.0
+      cape(i) = em_CAPE
+      wd(i) = em_wd
+      rflag(i) = float(iflag)
+c SB      kbas(i) = em_bas
+c SB      ktop(i) = em_top
+      dplcldt(i) = em_dplcldt
+      dplcldr(i) = em_dplcldr
+      DO l = 1, klev
+         d_t2(i,l) = dtime * em_d_t2(l) 
+         d_q2(i,l) = dtime * em_d_q2(l)
+         d_u2(i,l) = dtime * em_d_u2(l)
+         d_v2(i,l) = dtime * em_d_v2(l)
+
+         d_t(i,l) = dtime * em_d_t(l) 
+         d_q(i,l) = dtime * em_d_q(l)
+         d_u(i,l) = dtime * em_d_u(l)
+         d_v(i,l) = dtime * em_d_v(l)
+         do itra = 1, ntra
+         d_tra(i,l,itra) = dtime * em_d_tra(l,itra)
+         enddo
+         upwd(i,l) = em_upwd(l)
+         dnwd(i,l) = em_dnwd(l)
+         dnwdbis(i,l) = em_dnwdbis(l)
+         work1(i,l) = em_work1(l)
+         work2(i,l) = em_work2(l)
+         Ma(i,l)=emMa(l)
+         tvp(i,l)=em_TVP(l)
+         dtvpdt1(i,l) = em_dtvpdt1(l)
+         dtvpdq1(i,l) = em_dtvpdq1(l)
+
+         if (iflag_clw.eq.0) then
+            qcond_incld(i,l) = em_qcondc(l)
+         else if (iflag_clw.eq.1) then
+            qcond_incld(i,l) = em_qcond(l)
+         endif
+      ENDDO
+  999 CONTINUE
+
+c   On calcule une eau liquide diagnostique en fonction de la 
+c  precip.
+      if ( iflag_clw.eq.2 ) then
+      do l=1,klev
+         do i=1,klon
+            if (ktop(i)-kbas(i).gt.0.and.
+     s         l.ge.kbas(i).and.l.le.ktop(i)) then
+               qcond_incld(i,l)=rain(i)*8.e4
+c    s         *(pplay(i,l      )-paprs(i,ktop(i)+1))
+     s         /(pplay(i,kbas(i))-pplay(i,ktop(i)))
+c    s         **2
+            else
+               qcond_incld(i,l)=0.
+            endif
+         enddo
+         print*,'l=',l,',   qcond_incld=',qcond_incld(1,l)
+      enddo
+      endif
+ 
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conema3.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conema3.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conema3.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+      real epmax             ! 0.993
+      logical ok_adj_ema      ! F
+      integer iflag_clw      ! 0
+
+      common/comconema/epmax,ok_adj_ema,iflag_clw
+!$OMP THREADPRIVATE(/comconema/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conemav.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conemav.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conemav.F	(revision 984)
@@ -0,0 +1,155 @@
+!
+! $Header$
+!
+      SUBROUTINE conemav (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+ 
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Cape----output-R-CAPE (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev),cape(klon),tvp(klon,klev)
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+c
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev)
+cym       REAL cbmf(klon)
+cym       SAVE cbmf
+       REAL,ALLOCATABLE,SAVE :: cbmf(:)
+c$OMP THREADPRIVATE(cbmf)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c
+      IF (ifrst .EQ. 0) THEN
+         ifrst = 1
+	 allocate(cbmf(klon))
+         DO i = 1, klon
+          cbmf(i) = 0.
+         ENDDO
+      ENDIF
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+
+c
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+c
+      noff = 2
+      minorig = 2
+      CALL convect1(klon,klev,klev+1,noff,minorig,t,q,qs,u,v,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,rain,cbmf,dtime,Ma)
+c
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+c      call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION   ')
+c     if (klon.eq.1) then
+c        print*,'IFLAG ',iflag
+c     else
+c        write(*,'(96i1)') (iflag(i),i=2,klon-1)
+c     endif
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+        DO itra = 1,ntra
+          DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+          ENDDO
+        ENDDO
+      ENDDO
+ 
+c
+c
+c
+      RETURN
+      END
+ 
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conf_phys.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conf_phys.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conf_phys.F90	(revision 984)
@@ -0,0 +1,1065 @@
+!
+! $Header$
+!
+!
+!
+
+  subroutine conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, ok_instan, ok_hf, &
+ &                     fact_cldcon, facttemps,ok_newmicro,iflag_cldcon, &
+!IM&                   ratqsbas,ratqshaut,ip_ebil_phy, &
+ &                     ratqsbas,ratqshaut, &
+ &		       ok_ade, ok_aie, &
+ &                     bl95_b0, bl95_b1,&
+ &                     iflag_thermals,nsplit_thermals)
+
+   use IOIPSL
+   implicit none
+
+ include "conema3.h"
+ include "fisrtilp.h"
+ include "nuage.h"
+ include "YOMCST.h"
+!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
+include "clesphys.h"
+include "compbl.h"
+include "control.h"
+!
+! Configuration de la "physique" de LMDZ a l'aide de la fonction
+! GETIN de IOIPSL
+!
+! LF 05/2001
+!
+
+!
+! ocean:      type d'ocean (force, slab, couple)
+! ok_veget:   type de modele de vegetation
+! ok_journe:  sorties journalieres
+! ok_hf:  sorties haute frequence
+! ok_mensuel: sorties mensuelles
+! ok_instan:  sorties instantanees
+! ok_ade, ok_aie: apply or not aerosol direct and indirect effects
+! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 
+!
+
+
+! Sortie:
+  character (len = 6)  :: ocean
+  logical              :: ok_veget, ok_newmicro
+  logical              :: ok_journe, ok_mensuel, ok_instan, ok_hf
+  LOGICAL              :: ok_ade, ok_aie
+  REAL                 :: bl95_b0, bl95_b1
+  real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut
+  integer              :: iflag_cldcon
+
+  character (len = 6),SAVE  :: ocean_omp
+  logical,SAVE              :: ok_veget_omp, ok_newmicro_omp
+  logical,SAVE        :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp        
+  LOGICAL,SAVE        :: ok_ade_omp, ok_aie_omp
+  REAL,SAVE           :: bl95_b0_omp, bl95_b1_omp
+  REAL,SAVE           :: freq_ISCCP_omp, ecrit_ISCCP_omp
+  real,SAVE           :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp
+  real,SAVE           :: ratqshaut_omp
+  integer,SAVE        :: iflag_cldcon_omp, ip_ebil_phy_omp
+
+! Local
+  integer              :: numout = 6
+  real                 :: zzz
+
+  integer :: iflag_thermals,nsplit_thermals
+  integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
+
+  REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp,co2_ppm_omp
+  REAL,SAVE :: RCO2_omp,CH4_ppb_omp,RCH4_omp,N2O_ppb_omp,RN2O_omp,CFC11_ppt_omp
+  REAL,SAVE :: RCFC11_omp,CFC12_ppt_omp,RCFC12_omp,epmax_omp
+  LOGICAL,SAVE :: ok_adj_ema_omp
+  INTEGER,SAVE :: iflag_clw_omp
+  REAL,SAVE :: cld_lc_lsc_omp,cld_lc_con_omp,cld_tau_lsc_omp,cld_tau_con_omp
+  REAL,SAVE :: ffallv_lsc_omp, ffallv_con_omp,coef_eva_omp
+  LOGICAL,SAVE :: reevap_ice_omp
+  INTEGER,SAVE :: iflag_pdf_omp
+  REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
+  INTEGER,SAVE :: top_height_omp,overlap_omp
+  REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp
+  LOGICAL,SAVE :: ok_kzmin_omp
+  REAL, SAVE ::  fmagic_omp
+  INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp
+  CHARACTER*4, SAVE :: type_run_omp
+  LOGICAL,SAVE :: ok_isccp_omp
+  REAL,SAVE :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp
+  REAL,SAVE :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp
+  REAL,SAVE :: ecrit_tra_omp
+  LOGICAL, SAVE :: ok_slab_sicOBS_omp
+  REAL,SAVE :: cvl_corr_omp
+  LOGICAL,SAVE :: ok_lic_melt_omp
+
+  LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp
+  LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
+  INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
+
+!
+!
+!
+
+!$OMP MASTER
+!Config Key  = OCEAN 
+!Config Desc = Type d'ocean
+!Config Def  = force
+!Config Help = Type d'ocean utilise: force, slab,couple
+!
+  ocean_omp = 'force '
+  call getin('OCEAN', ocean_omp)
+!
+!Config Key  = VEGET 
+!Config Desc = Type de modele de vegetation
+!Config Def  = .false.
+!Config Help = Type de modele de vegetation utilise
+!
+  ok_veget_omp = .false.
+  call getin('VEGET', ok_veget_omp)
+!
+!Config Key  = OK_journe
+!Config Desc = Pour des sorties journalieres 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histday contenant les sorties
+!              journalieres 
+!
+  ok_journe_omp = .false.
+  call getin('OK_journe', ok_journe_omp)
+!
+!Config Key  = ok_hf
+!Config Desc = Pour des sorties haute frequence
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histhf contenant les sorties
+!              haute frequence ( 3h ou 6h)
+!
+  ok_hf_omp = .false.
+  call getin('ok_hf', ok_hf_omp)
+!
+!Config Key  = OK_mensuel
+!Config Desc = Pour des sorties mensuelles 
+!Config Def  = .true.
+!Config Help = Pour creer le fichier histmth contenant les sorties
+!              mensuelles 
+!
+  ok_mensuel_omp = .true.
+  call getin('OK_mensuel', ok_mensuel_omp)
+!
+!Config Key  = OK_instan
+!Config Desc = Pour des sorties instantanees 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histins contenant les sorties
+!              instantanees 
+!
+  ok_instan_omp = .false.
+  call getin('OK_instan', ok_instan_omp)
+!
+!Config Key  = ok_ade
+!Config Desc = Aerosol direct effect or not?
+!Config Def  = .false.
+!Config Help = Used in radlwsw.F
+!
+  ok_ade_omp = .false.
+  call getin('ok_ade', ok_ade_omp)
+
+!
+!Config Key  = ok_aie
+!Config Desc = Aerosol indirect effect or not?
+!Config Def  = .false.
+!Config Help = Used in nuage.F and radlwsw.F
+!
+  ok_aie_omp = .false.
+  call getin('ok_aie', ok_aie_omp)
+
+!
+!Config Key  = bl95_b0
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b0_omp = 2.
+  call getin('bl95_b0', bl95_b0_omp)
+
+!Config Key  = bl95_b1
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b1_omp = 0.2
+  call getin('bl95_b1', bl95_b1_omp)
+
+!Config Key  = freq_ISCCP
+!Config Desc = Frequence d'appel du simulateur ISCCP en secondes;
+!              par defaut 10800, i.e. 3 heures 
+!Config Def  = 10800.
+!Config Help = Used in ini_histISCCP.h
+!
+  freq_ISCCP_omp = 10800.
+  call getin('freq_ISCCP', freq_ISCCP_omp)
+!
+!Config Key  = ecrit_ISCCP
+!Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours;
+!              par defaut 1., i.e. 1 jour
+!Config Def  = 1.
+!Config Help = Used in ini_histISCCP.h
+!
+!
+  ecrit_ISCCP_omp = 1.
+  call getin('ecrit_ISCCP', ecrit_ISCCP_omp)
+!
+!Config Key  = ip_ebil_phy
+!Config Desc = Niveau de sortie pour les diags bilan d'energie 
+!Config Def  = 0
+!Config Help = 
+!               
+!
+  ip_ebil_phy_omp = 0
+  call getin('ip_ebil_phy', ip_ebil_phy_omp)
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG
+!!
+!Config Key  = R_ecc
+!Config Desc = Excentricite
+!Config Def  = 0.016715
+!Config Help = 
+!               
+!valeur AMIP II
+  R_ecc_omp = 0.016715
+  call getin('R_ecc', R_ecc_omp)
+!!
+!Config Key  = R_peri
+!Config Desc = Equinoxe
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_peri_omp = 102.7
+  call getin('R_peri', R_peri_omp)
+!!
+!Config Key  = R_incl
+!Config Desc = Inclinaison
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_incl_omp = 23.441
+  call getin('R_incl', R_incl_omp)
+!!
+!Config Key  = solaire
+!Config Desc = Constante solaire en W/m2
+!Config Def  = 1365.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  solaire_omp = 1365.
+  call getin('solaire', solaire_omp)
+!!
+!Config Key  = co2_ppm
+!Config Desc = concentration du gaz carbonique en ppmv
+!Config Def  = 348.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  co2_ppm_omp = 348.
+  call getin('co2_ppm', co2_ppm_omp)
+!!
+!Config Key  = RCO2
+!Config Desc = Concentration du CO2
+!Config Def  = co2_ppm * 1.0e-06  * 44.011/28.97
+!Config Def  = 348. * 1.0e-06  * 44.011/28.97
+!Config Help = 
+!               
+! RCO2 = 5.286789092164308E-04
+!ancienne valeur
+  RCO2_omp = co2_ppm_omp * 1.0e-06  * 44.011/28.97 ! pour co2_ppm=348.
+
+!!  call getin('RCO2', RCO2)
+!!
+!Config Key  = RCH4
+!Config Desc = Concentration du CH4
+!Config Def  = 1.65E-06* 16.043/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RCH4 = 1.65E-06* 16.043/28.97
+! RCH4 = 9.137366240938903E-07
+!
+!ancienne valeur
+! RCH4 = 1.72E-06* 16.043/28.97
+!OK call getin('RCH4', RCH4)
+  zzz = 1650.
+  call getin('CH4_ppb', zzz)
+  CH4_ppb_omp = zzz
+  RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97
+!!
+!Config Key  = RN2O
+!Config Desc = Concentration du N2O
+!Config Def  = 306.E-09* 44.013/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RN2O = 306.E-09* 44.013/28.97
+! RN2O = 4.648939592682085E-07
+!
+!ancienne valeur
+! RN2O = 310.E-09* 44.013/28.97
+!OK  call getin('RN2O', RN2O)
+  zzz=306.
+  call getin('N2O_ppb', zzz)
+  N2O_ppb_omp = zzz
+  RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97
+!!
+!Config Key  = RCFC11
+!Config Desc = Concentration du CFC11
+!Config Def  = 280.E-12* 137.3686/28.97
+!Config Help = 
+!               
+!
+!OK RCFC11 = 280.E-12* 137.3686/28.97
+  zzz = 280.
+  call getin('CFC11_ppt',zzz)
+  CFC11_ppt_omp = zzz
+  RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97
+! RCFC11 = 1.327690990680013E-09
+!OK call getin('RCFC11', RCFC11)
+!!
+!Config Key  = RCFC12
+!Config Desc = Concentration du CFC12
+!Config Def  = 484.E-12* 120.9140/28.97
+!Config Help = 
+!               
+!
+!OK RCFC12 = 484.E-12* 120.9140/28.97
+  zzz = 484.
+  call getin('CFC12_ppt',zzz)
+  CFC12_ppt_omp = zzz
+  RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97
+! RCFC12 = 2.020102726958923E-09
+!OK call getin('RCFC12', RCFC12)
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END
+!!
+!! KE
+!
+
+!Config key  = cvl_corr
+!Config Desc = Facteur multiplication des precip convectives dans KE
+!Config Def  = 1.00
+!Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire
+  cvl_corr_omp = 1.00
+  CALL getin('cvl_corr', cvl_corr_omp)
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02
+! Constantes precedemment dans dyn3d/conf_gcm
+
+!Config  Key  = cycle_diurne
+!Config  Desc = Cycle ddiurne
+!Config  Def  = y
+!Config  Help = Cette option permet d'eteidre le cycle diurne.
+!Config         Peut etre util pour accelerer le code !
+       cycle_diurne_omp = .TRUE.
+       CALL getin('cycle_diurne',cycle_diurne_omp)
+
+!Config  Key  = soil_model
+!Config  Desc = Modele de sol
+!Config  Def  = y
+!Config  Help = Choix du modele de sol (Thermique ?)
+!Config         Option qui pourait un string afin de pouvoir
+!Config         plus de choix ! Ou meme une liste d'options !
+       soil_model_omp = .TRUE.
+       CALL getin('soil_model',soil_model_omp)
+
+!Config  Key  = new_oliq
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = y
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       new_oliq_omp = .TRUE.
+       CALL getin('new_oliq',new_oliq_omp)
+
+!Config  Key  = ok_orodr
+!Config  Desc = Orodr ???
+!Config  Def  = y
+!Config  Help = Y en a pas comprendre !
+!Config         
+       ok_orodr_omp = .TRUE.
+       CALL getin('ok_orodr',ok_orodr_omp)
+
+!Config  Key  =  ok_orolf
+!Config  Desc = Orolf ??
+!Config  Def  = y
+!Config  Help = Connais pas !
+       ok_orolf_omp = .TRUE.
+       CALL getin('ok_orolf_omp', ok_orolf_omp)
+
+!Config  Key  = ok_limitvrai
+!Config  Desc = Force la lecture de la bonne annee
+!Config  Def  = n
+!Config  Help = On peut forcer le modele a lire le
+!Config         fichier SST de la bonne annee. C'est une tres bonne
+!Config         idee, pourquoi ne pas mettre toujours a y ???
+       ok_limitvrai_omp = .FALSE.
+       CALL getin('ok_limitvrai',ok_limitvrai_omp)
+
+!Config  Key  = nbapp_rad
+!Config  Desc = Frequence d'appel au rayonnement
+!Config  Def  = 12
+!Config  Help = Nombre  d'appels des routines de rayonnements
+!Config         par jour.
+       nbapp_rad_omp = 12
+       CALL getin('nbapp_rad',nbapp_rad_omp)
+
+!Config  Key  = iflag_con
+!Config  Desc = Flag de convection
+!Config  Def  = 2
+!Config  Help = Flag  pour la convection les options suivantes existent :
+!Config         1 pour LMD,
+!Config         2 pour Tiedtke,
+!Config         3 pour CCM(NCAR)  
+       iflag_con_omp = 2
+       CALL getin('iflag_con',iflag_con_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Config Key  = epmax
+!Config Desc = Efficacite precip
+!Config Def  = 0.993
+!Config Help = 
+!
+  epmax_omp = .993
+  call getin('epmax', epmax_omp)
+!
+!Config Key  = ok_adj_ema
+!Config Desc =  
+!Config Def  = false
+!Config Help = 
+!
+  ok_adj_ema_omp = .false.
+  call getin('ok_adj_ema',ok_adj_ema_omp)
+!
+!Config Key  = iflag_clw
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clw_omp = 0
+  call getin('iflag_clw',iflag_clw_omp)
+!
+!Config Key  = cld_lc_lsc 
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_lsc_omp = 2.6e-4
+  call getin('cld_lc_lsc',cld_lc_lsc_omp)
+!
+!Config Key  = cld_lc_con
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_con_omp = 2.6e-4
+  call getin('cld_lc_con',cld_lc_con_omp)
+!
+!Config Key  = cld_tau_lsc
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_lsc_omp = 3600.
+  call getin('cld_tau_lsc',cld_tau_lsc_omp)
+!
+!Config Key  = cld_tau_con
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_con_omp = 3600.
+  call getin('cld_tau_con',cld_tau_con_omp)
+!
+!Config Key  = ffallv_lsc
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_lsc_omp = 1.
+  call getin('ffallv_lsc',ffallv_lsc_omp)
+!
+!Config Key  = ffallv_con
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_con_omp = 1.
+  call getin('ffallv_con',ffallv_con_omp)
+!
+!Config Key  = coef_eva
+!Config Desc =  
+!Config Def  = 2.e-5
+!Config Help = 
+!
+  coef_eva_omp = 2.e-5
+  call getin('coef_eva',coef_eva_omp)
+!
+!Config Key  = reevap_ice
+!Config Desc =  
+!Config Def  = .false.
+!Config Help = 
+!
+  reevap_ice_omp = .false.
+  call getin('reevap_ice',reevap_ice_omp)
+!
+!Config Key  = iflag_cldcon 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_cldcon_omp = 1
+  call getin('iflag_cldcon',iflag_cldcon_omp)
+
+!
+!Config Key  = iflag_pdf 
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_pdf_omp = 0
+  call getin('iflag_pdf',iflag_pdf_omp)
+!
+!Config Key  = fact_cldcon
+!Config Desc =  
+!Config Def  = 0.375
+!Config Help = 
+!
+  fact_cldcon_omp = 0.375
+  call getin('fact_cldcon',fact_cldcon_omp)
+
+!
+!Config Key  = facttemps
+!Config Desc =  
+!Config Def  = 1.e-4
+!Config Help = 
+!
+  facttemps_omp = 1.e-4
+  call getin('facttemps',facttemps_omp)
+
+!
+!Config Key  = ok_newmicro
+!Config Desc =  
+!Config Def  = .true.
+!Config Help = 
+!
+  ok_newmicro_omp = .true.
+  call getin('ok_newmicro',ok_newmicro_omp)
+!
+!Config Key  = ratqsbas
+!Config Desc =  
+!Config Def  = 0.01
+!Config Help = 
+!
+  ratqsbas_omp = 0.01
+  call getin('ratqsbas',ratqsbas_omp)
+!
+!Config Key  = ratqshaut
+!Config Desc =  
+!Config Def  = 0.3
+!Config Help = 
+!
+  ratqshaut_omp = 0.3
+  call getin('ratqshaut',ratqshaut_omp)
+
+!
+!Config Key  = rad_froid
+!Config Desc =  
+!Config Def  = 35.0
+!Config Help = 
+!
+  rad_froid_omp = 35.0
+  call getin('rad_froid',rad_froid_omp)
+
+!
+!Config Key  = rad_chau1
+!Config Desc =  
+!Config Def  = 13.0
+!Config Help = 
+!
+  rad_chau1_omp = 13.0
+  call getin('rad_chau1',rad_chau1_omp)
+
+!
+!Config Key  = rad_chau2
+!Config Desc =  
+!Config Def  = 9.0
+!Config Help = 
+!
+  rad_chau2_omp = 9.0
+  call getin('rad_chau2',rad_chau2_omp)
+
+!
+!Config Key  = top_height
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  top_height_omp = 3
+  call getin('top_height',top_height_omp)
+
+!
+!Config Key  = overlap
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  overlap_omp = 3
+  call getin('overlap',overlap_omp)
+
+
+!
+!
+!Config Key  = cdmmax
+!Config Desc =
+!Config Def  = 1.3E-3
+!Config Help =
+!
+  cdmmax_omp = 1.3E-3
+  call getin('cdmmax',cdmmax_omp)
+
+!
+!Config Key  = cdhmax
+!Config Desc =
+!Config Def  = 1.1E-3
+!Config Help =
+!
+  cdhmax_omp = 1.1E-3
+  call getin('cdhmax',cdhmax_omp)
+
+!261103
+!
+!Config Key  = ksta
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_omp = 1.0e-10
+  call getin('ksta',ksta_omp)
+
+!
+!Config Key  = ksta_ter
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_ter_omp = 1.0e-10
+  call getin('ksta_ter',ksta_ter_omp)
+
+!
+!Config Key  = ok_kzmin
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+  ok_kzmin_omp = .true.
+  call getin('ok_kzmin',ok_kzmin_omp)
+
+!
+!Config Key  = fmagic
+!Config Desc = 
+!Config Def  = 1.
+!Config Help = Used in albedo.F
+!
+  fmagic_omp = 1.
+  call getin('fmagic',fmagic_omp)
+
+!Config Key = ok_lic_melt
+!Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau
+!Config Def  = .false.
+!Config Help = mettre a .false. pour assurer la conservation en eau
+  ok_lic_melt_omp = .false.
+  call getin('ok_lic_melt', ok_lic_melt_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Config Key  = iflag_pbl
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_pbl_omp = 1
+  call getin('iflag_pbl',iflag_pbl_omp)
+!
+!Config Key  = iflag_thermals
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_thermals_omp = 0
+  call getin('iflag_thermals',iflag_thermals_omp)
+!
+!
+!Config Key  = nsplit_thermals
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  nsplit_thermals_omp = 1
+  call getin('nsplit_thermals',nsplit_thermals_omp)
+
+
+
+!
+!Config Key  = lev_histhf
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histhf_omp = 1
+  call getin('lev_histhf',lev_histhf_omp)
+
+!
+!Config Key  = lev_histday
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histday_omp = 1
+  call getin('lev_histday',lev_histday_omp)
+
+!
+!Config Key  = lev_histmth
+!Config Desc =
+!Config Def  = 2
+!Config Help =
+!
+  lev_histmth_omp = 2
+  call getin('lev_histmth',lev_histmth_omp)
+
+  !
+!Config Key  = type_run
+!Config Desc =
+!Config Def  = 'AMIP'/'CFMIP'  ou 'CLIM'/'ENSP'
+!Config Help =
+!
+  type_run_omp = 'AMIP'
+  call getin('type_run',type_run_omp)
+
+!
+!Config Key  = ok_isccp
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+! ok_isccp = .true.
+  ok_isccp_omp = .false.
+  call getin('ok_isccp',ok_isccp_omp)
+
+!
+! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone 
+! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc"
+!
+!Config Key  = lonmin_ins
+!Config Desc = 100.  
+!Config Def  = longitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   lonmin_ins_omp = 100.
+   call getin('lonmin_ins',lonmin_ins_omp)
+!
+!Config Key  = lonmax_ins
+!Config Desc = 130. 
+!Config Def  = longitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   lonmax_ins = 130.
+   call getin('lonmax_ins',lonmax_ins_omp)
+!
+!Config Key  = latmin_ins
+!Config Desc = -20.  
+!Config Def  = latitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   latmin_ins_omp = -20.
+   call getin('latmin_ins',latmin_ins_omp)
+!
+!Config Key  = latmax_ins
+!Config Desc = 20. 
+!Config Def  = latitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   latmax_ins_omp = 20.
+   call getin('latmax_ins',latmax_ins_omp)
+!
+!Config Key  = ecrit_hf
+!Config Desc =
+!Config Def  = 1./8. !toutes les 3h
+!Config Help =
+!
+  ecrit_hf_omp = 1./8.
+  call getin('ecrit_hf',ecrit_hf_omp)
+!
+!Config Key  = ecrit_day
+!Config Desc =
+!Config Def  = 1.0 !tous les jours
+!Config Help = nombre de jours pour ecriture fichier histday.nc
+!
+  ecrit_day_omp = 1.0
+  call getin('ecrit_day',ecrit_day_omp)
+!
+!Config Key  = ecrit_mth
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_mth_omp = 30.
+  call getin('ecrit_mth',ecrit_mth_omp)
+!
+!Config Key  = ecrit_tra
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_tra_omp = 30.
+  call getin('ecrit_tra',ecrit_tra_omp)
+!
+!Config Key  = ecrit_reg
+!Config Desc =
+!Config Def  = 0.25  !4 fois par jour
+!Config Help =
+!
+  ecrit_reg_omp = 0.25   !4 fois par jour
+  call getin('ecrit_reg',ecrit_reg_omp)
+!
+!
+!
+!Config Key  = ok_slab_sicOBS
+!Config Desc =
+!Config Def  = .true.
+!Config Help = Pour faire tourner le slab avec fraction 
+!              de glace de mer Observee
+!
+  ok_slab_sicOBS_omp = .true.
+  call getin('ok_slab_sicOBS', ok_slab_sicOBS_omp)
+
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+    R_ecc = R_ecc_omp
+    R_peri = R_peri_omp
+    R_incl = R_incl_omp
+    solaire = solaire_omp
+    co2_ppm = co2_ppm_omp
+    RCO2 = RCO2_omp
+    CH4_ppb = CH4_ppb_omp
+    RCH4 = RCH4_omp
+    N2O_ppb = N2O_ppb_omp
+    RN2O = RN2O_omp
+    CFC11_ppt = CFC11_ppt_omp
+    RCFC11 = RCFC11_omp
+    CFC12_ppt = CFC12_ppt_omp
+    RCFC12 = RCFC12_omp
+
+
+    cycle_diurne = cycle_diurne_omp
+    soil_model = soil_model_omp
+    new_oliq = new_oliq_omp
+    ok_orodr = ok_orodr_omp
+    ok_orolf = ok_orolf_omp
+    ok_limitvrai = ok_limitvrai_omp
+    nbapp_rad = nbapp_rad_omp
+    iflag_con = iflag_con_omp
+
+
+    epmax = epmax_omp
+    ok_adj_ema = ok_adj_ema_omp
+    iflag_clw = iflag_clw_omp
+    cld_lc_lsc = cld_lc_lsc_omp
+    cld_lc_con = cld_lc_con_omp
+    cld_tau_lsc = cld_tau_lsc_omp
+    cld_tau_con = cld_tau_con_omp
+    ffallv_lsc = ffallv_lsc_omp
+    ffallv_con = ffallv_con_omp
+    coef_eva = coef_eva_omp
+    reevap_ice = reevap_ice_omp
+    iflag_pdf = iflag_pdf_omp
+    rad_froid = rad_froid_omp
+    rad_chau1 = rad_chau1_omp
+    rad_chau2 = rad_chau2_omp
+    top_height = top_height_omp
+    overlap = overlap_omp
+    cdmmax = cdmmax_omp
+    cdhmax = cdhmax_omp
+    ksta = ksta_omp
+    ksta_ter = ksta_ter_omp
+    ok_kzmin = ok_kzmin_omp
+    fmagic = fmagic_omp
+    iflag_pbl = iflag_pbl_omp
+    lev_histhf = lev_histhf_omp
+    lev_histday = lev_histday_omp
+    lev_histmth = lev_histmth_omp
+
+    ocean = ocean_omp
+    ok_veget = ok_veget_omp
+    ok_newmicro = ok_newmicro_omp
+    ok_journe = ok_journe_omp
+    ok_hf = ok_hf_omp
+    ok_mensuel = ok_mensuel_omp
+    ok_instan = ok_instan_omp
+    freq_ISCCP = freq_ISCCP_omp
+    ecrit_ISCCP = ecrit_ISCCP_omp
+    ok_ade = ok_ade_omp
+    ok_aie = ok_aie_omp
+    bl95_b0 = bl95_b0_omp
+    bl95_b1 = bl95_b1_omp
+    fact_cldcon = fact_cldcon_omp
+    facttemps = facttemps_omp
+    ratqsbas = ratqsbas_omp
+    ratqshaut = ratqshaut_omp
+    iflag_cldcon = iflag_cldcon_omp
+    ip_ebil_phy = ip_ebil_phy_omp
+    iflag_thermals = iflag_thermals_omp
+    nsplit_thermals = nsplit_thermals_omp
+    type_run = type_run_omp
+    ok_isccp = ok_isccp_omp
+    lonmin_ins = lonmin_ins_omp
+    lonmax_ins = lonmax_ins_omp
+    latmin_ins = latmin_ins_omp
+    latmax_ins = latmax_ins_omp
+    ecrit_hf   = ecrit_hf_omp
+    ecrit_day = ecrit_day_omp
+    ecrit_mth = ecrit_mth_omp
+    ecrit_tra = ecrit_tra_omp
+    ecrit_reg = ecrit_reg_omp
+    ok_slab_sicOBS = ok_slab_sicOBS_omp
+    cvl_corr = cvl_corr_omp
+    ok_lic_melt = ok_lic_melt_omp
+
+!$OMP MASTER
+
+  write(numout,*)' ##############################################'
+  write(numout,*)' Configuration des parametres de la physique: '
+  write(numout,*)' Config ocean = ', ocean
+  write(numout,*)' Config veget = ', ok_veget
+  write(numout,*)' Sortie journaliere = ', ok_journe
+  write(numout,*)' Sortie haute frequence = ', ok_hf
+  write(numout,*)' Sortie mensuelle = ', ok_mensuel
+  write(numout,*)' Sortie instantanee = ', ok_instan
+  write(numout,*)' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP
+  write(numout,*)' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP
+  write(numout,*)' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy
+  write(numout,*)' Excentricite = ',R_ecc
+  write(numout,*)' Equinoxe = ',R_peri
+  write(numout,*)' Inclinaison =',R_incl
+  write(numout,*)' Constante solaire =',solaire
+  write(numout,*)' co2_ppm =',co2_ppm
+  write(numout,*)' RCO2 = ',RCO2
+  write(numout,*)' CH4_ppb =',CH4_ppb,' RCH4 = ',RCH4
+  write(numout,*)' N2O_ppb =',N2O_ppb,' RN2O =  ',RN2O
+  write(numout,*)' CFC11_ppt=',CFC11_ppt,' RCFC11 =  ',RCFC11
+  write(numout,*)' CFC12_ppt=',CFC12_ppt,' RCFC12 =  ',RCFC12
+  write(numout,*)' cvl_corr=', cvl_corr
+  write(numout,*)'ok_lic_melt=', ok_lic_melt
+  write(numout,*)'cycle_diurne=',cycle_diurne
+  write(numout,*)'soil_model=',soil_model
+  write(numout,*)'new_oliq=',new_oliq
+  write(numout,*)'ok_orodr=',ok_orodr
+  write(numout,*)'ok_orolf=',ok_orolf
+  write(numout,*)'ok_limitvrai=',ok_limitvrai
+  write(numout,*)'nbapp_rad=',nbapp_rad
+  write(numout,*)'iflag_con=',iflag_con
+  write(numout,*)' epmax = ', epmax
+  write(numout,*)' ok_adj_ema = ', ok_adj_ema
+  write(numout,*)' iflag_clw = ', iflag_clw
+  write(numout,*)' cld_lc_lsc = ', cld_lc_lsc
+  write(numout,*)' cld_lc_con = ', cld_lc_con
+  write(numout,*)' cld_tau_lsc = ', cld_tau_lsc
+  write(numout,*)' cld_tau_con = ', cld_tau_con
+  write(numout,*)' ffallv_lsc = ', ffallv_lsc
+  write(numout,*)' ffallv_con = ', ffallv_con
+  write(numout,*)' coef_eva = ', coef_eva
+  write(numout,*)' reevap_ice = ', reevap_ice
+  write(numout,*)' iflag_pdf = ', iflag_pdf
+  write(numout,*)' iflag_cldcon = ', iflag_cldcon
+  write(numout,*)' fact_cldcon = ', fact_cldcon
+  write(numout,*)' facttemps = ', facttemps
+  write(numout,*)' ok_newmicro = ',ok_newmicro 
+  write(numout,*)' ratqsbas = ',ratqsbas 
+  write(numout,*)' ratqshaut = ',ratqshaut 
+  write(numout,*)' top_height = ',top_height 
+  write(numout,*)' overlap = ',overlap 
+  write(numout,*)' cdmmax = ',cdmmax 
+  write(numout,*)' cdhmax = ',cdhmax 
+  write(numout,*)' ksta = ',ksta 
+  write(numout,*)' ksta_ter = ',ksta_ter 
+  write(numout,*)' ok_kzmin = ',ok_kzmin 
+  write(numout,*)' fmagic = ',fmagic
+  write(numout,*)' ok_ade = ',ok_ade
+  write(numout,*)' ok_aie = ',ok_aie
+  write(numout,*)' bl95_b0 = ',bl95_b0
+  write(numout,*)' bl95_b1 = ',bl95_b1
+  write(numout,*)' lev_histhf = ',lev_histhf 
+  write(numout,*)' lev_histday = ',lev_histday 
+  write(numout,*)' lev_histmth = ',lev_histmth 
+  write(numout,*)' iflag_pbl = ', iflag_pbl
+  write(numout,*)' iflag_thermals = ', iflag_thermals
+  write(numout,*)' type_run = ',type_run 
+  write(numout,*)' ok_isccp = ',ok_isccp 
+  write(numout,*)' lonmin lonmax latmin latmax bilKP_ins =',&
+ & lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+  write(numout,*)' ecrit_ hf, day, mth, reg, tra, ISCCP',&
+ & ecrit_hf, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP
+
+!$OMP END MASTER
+
+  return
+  
+  end subroutine conf_phys
+
+!
+!#################################################################
+!
+
+   subroutine conf_interface(tau_calv)
+
+   use IOIPSL
+   implicit none
+
+! Configuration de l'interace atm/surf
+!
+! tau_calv:    temps de relaxation pour la fonte des glaciers
+
+  REAL          :: tau_calv
+  REAL,SAVE     :: tau_calv_omp
+
+! Local
+  integer              :: numout = 6
+!
+!Config Key  = tau_calv
+!Config Desc = temps de relaxation pour fonte des glaciers en jours
+!Config Def  = 1 an 
+!Config Help = 
+!
+  tau_calv_omp = 360.*10.
+!$OMP MASTER
+  call getin('tau_calv',tau_calv_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  tau_calv=tau_calv_omp
+  
+!$OMP MASTER
+  write(numout,*)' ##############################################'
+  WRITE(numout,*)' Configuration de l''interface atm/surfaces  : '
+  WRITE(numout,*)' tau_calv = ',tau_calv
+!$OMP END MASTER
+
+  return
+
+  end subroutine conf_interface
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conflx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conflx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conflx.F	(revision 984)
@@ -0,0 +1,1676 @@
+!
+! $Header$
+!
+      SUBROUTINE conflx (dtime,pres_h,pres_f,
+     e                   t, q, con_t, con_q, pqhfl, w,
+     s                   d_t, d_q, rain, snow,
+     s                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s                   kcbot, kctop, kdtop, pmflxr, pmflxs)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+c Objet: Schema flux de masse pour la convection 
+c        (schema de Tiedtke avec qqs modifications mineures)
+c Dec.97: Prise en compte des modifications introduites par
+c         Olivier Boucher et Alexandre Armengaud pour melange
+c         et lessivage des traceurs passifs.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c Entree:
+      REAL dtime            ! pas d'integration (s)
+      REAL pres_h(klon,klev+1) ! pression half-level (Pa)
+      REAL pres_f(klon,klev)! pression full-level (Pa)
+      REAL t(klon,klev)     ! temperature (K)
+      REAL q(klon,klev)     ! humidite specifique (g/g)
+      REAL w(klon,klev)     ! vitesse verticale (Pa/s)
+      REAL con_t(klon,klev) ! convergence de temperature (K/s)
+      REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s)
+      REAL pqhfl(klon)      ! evaporation (negative vers haut) mm/s
+c Sortie:
+      REAL d_t(klon,klev)   ! incrementation de temperature
+      REAL d_q(klon,klev)   ! incrementation d'humidite
+      REAL pmfu(klon,klev)  ! flux masse (kg/m2/s) panache ascendant
+      REAL pmfd(klon,klev)  ! flux masse (kg/m2/s) panache descendant
+      REAL pen_u(klon,klev)
+      REAL pen_d(klon,klev)
+      REAL pde_u(klon,klev)
+      REAL pde_d(klon,klev)
+      REAL rain(klon)       ! pluie (mm/s)
+      REAL snow(klon)       ! neige (mm/s)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER kcbot(klon)  ! niveau du bas de la convection
+      INTEGER kctop(klon)  ! niveau du haut de la convection
+      INTEGER kdtop(klon)  ! niveau du haut des downdrafts
+c Local:
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pqs(klon,klev)
+      REAL pvervel(klon,klev)
+      LOGICAL land(klon)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL paprsf(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL zcvgq(klon,klev)
+      REAL zcvgt(klon,klev)
+cAA
+      REAL zmfu(klon,klev) 
+      REAL zmfd(klon,klev)
+      REAL zen_u(klon,klev)
+      REAL zen_d(klon,klev)
+      REAL zde_u(klon,klev)
+      REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
+cAA
+
+c
+      INTEGER i, k
+      REAL zdelta, zqsat
+c
+#include "FCTTRE.h"
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kcbot(i) = 0
+         kctop(i) = 0
+         kdtop(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         pmfu(i,k) = 0.0
+         pmfd(i,k) = 0.0
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+         zmfu(i,k) = 0.0
+         zmfd(i,k) = 0.0
+         zen_u(i,k) = 0.0
+         zde_u(i,k) = 0.0
+         zen_d(i,k) = 0.0
+         zde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c calculer la nature du sol (pour l'instant, ocean partout)
+      DO i = 1, klon
+         land(i) = .FALSE.
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         paprsf(i,k) = pres_f(i,klev-k+1)
+         paprs(i,k) = pres_h(i,klev+1-k+1)
+         pvervel(i,k) = w(i,klev+1-k)
+         zcvgt(i,k) = con_t(i,klev-k+1)
+         zcvgq(i,k) = con_q(i,klev-k+1)
+c
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k)))
+         zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k)
+         zqsat=MIN(0.5,zqsat)
+         zqsat=zqsat/(1.-RETV  *zqsat)
+         pqs(i,k) = zqsat
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pres_h(i,1)
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                   / (0.5*(paprs(i,klev+1)+paprsf(i,klev)))
+     .                   * (paprs(i,klev+1)-paprsf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1)
+     .              + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1)
+     .                   * (paprsf(i,k+1)-paprsf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL flxmain(dtime, pt, pq, pqs, pqhfl,
+     .             paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel,
+     .             rain, snow, kcbot, kctop, kdtop,
+     .             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     .             d_t_bis, d_q_bis, zmflxr, zmflxs)
+C
+cAA--------------------------------------------------------
+cAA rem : De la meme facon que l'on effectue le reindicage 
+cAA       pour la temperature t et le champ q 
+cAA       on reindice les flux necessaires a la convection 
+cAA       des traceurs
+cAA--------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = dtime*d_q_bis(i,k)
+         d_t(i,klev+1-k) = dtime*d_t_bis(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         pmfu(i,1)= 0.
+         pmfd(i,1)= 0.
+         pen_d(i,1)= 0.
+         pde_d(i,1)= 0.
+      ENDDO
+     
+      DO k = 2, klev
+      DO i = 1, klon
+         pmfu(i,klev+2-k)= zmfu(i,k)
+         pmfd(i,klev+2-k)= zmfd(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pen_u(i,klev+1-k)=  zen_u(i,k)
+         pde_u(i,klev+1-k)=  zde_u(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+         pen_d(i,klev+1-k)= -zen_d(i,k+1)
+         pde_d(i,klev+1-k)= -zde_d(i,k+1)
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,klev+2-k)= zmflxr(i,k)
+         pmflxs(i,klev+2-k)= zmflxs(i,k)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c--------------------------------------------------------------------
+      SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph,
+     .                   pgeo, ldland, ptte, pqte, pvervel,
+     .                   prsfc, pssfc, kcbot, kctop, kdtop,
+c     *                   ldcum, ktype,
+     .                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .                   dt_con, dq_con, pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C     ------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     ----------------------------------------------------------------
+      REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev)
+      REAL ptte(klon,klev)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev)
+      REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1)
+      REAL pqhfl(klon)
+c
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev)
+      REAL prsfc(klon), pssfc(klon)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+c
+      REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev)
+      REAL zgeoh(klon,klev)
+      REAL zmfub(klon), zmfub1(klon)
+      REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev)
+      REAL zdmfup(klon,klev), zdpmel(klon,klev)
+      REAL zentr(klon), zhcbase(klon)
+      REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+      REAL zrfl(klon)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER  ilab(klon,klev), ictop0(klon)
+      LOGICAL  llo1
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+      REAL zmfmax, zdh
+      REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+      REAL zhhat, zpbmpt, zgam, zeps, zfac
+      INTEGER i, k, ikb, itopm2, kcum
+c
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL pen_d(klon,klev), pde_d(klon,klev)
+c
+      REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev)
+      REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev)
+      INTEGER kdtop(klon)
+      LOGICAL lddraf(klon)
+C---------------------------------------------------------------------
+      LOGICAL firstcal
+      SAVE firstcal
+      DATA firstcal / .TRUE. /
+c$OMP THREADPRIVATE(firstcal)
+C---------------------------------------------------------------------
+      IF (firstcal) THEN
+         CALL flxsetup
+         firstcal = .FALSE.
+      ENDIF
+C---------------------------------------------------------------------
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         dt_con(i,k) = 0.0
+         dq_con(i,k) = 0.0
+      ENDDO
+      ENDDO
+c----------------------------------------------------------------------
+c initialiser les variables et faire l'interpolation verticale
+c----------------------------------------------------------------------
+      CALL flxini(pten, pqen, pqsen, pgeo,
+     .     paph, zgeoh, ztenh, zqenh, zqsenh,
+     .     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp,
+     .     pmfu, zmfus, zmfuq, zdmfup,
+     .     zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+c---------------------------------------------------------------------
+c determiner les valeurs au niveau de base de la tour convective
+c---------------------------------------------------------------------
+      CALL flxbase(ztenh, zqenh, zgeoh, paph,
+     *            ptu, pqu, plu, ldcum, kcbot, ilab)
+c---------------------------------------------------------------------
+c calculer la convergence totale de l'humidite et celle en provenance
+c de la couche limite, plus precisement, la convergence integree entre
+c le sol et la base de la convection. Cette derniere convergence est
+c comparee avec l'evaporation obtenue dans la couche limite pour
+c determiner le type de la convection
+c---------------------------------------------------------------------
+      k=1
+      DO i = 1, klon
+         zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k))
+         zdhpbl(i) = 0.0
+         zdqpbl(i) = 0.0
+      ENDDO
+c
+      DO k=2,klev
+      DO i = 1, klon
+          zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+          IF (k.GE.kcbot(i)) THEN
+             zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+             zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k))
+     .                          *(paph(i,k+1)-paph(i,k))
+          ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         ktype(i) = 2
+         if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1
+ccc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+      ENDDO
+c
+c---------------------------------------------------------------------
+c determiner le flux de masse entrant a travers la base.
+c on ignore, pour l'instant, l'effet du panache descendant
+c---------------------------------------------------------------------
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb)
+         zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN
+            zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub(i) = 0.01
+            ldcum(i)=.FALSE.
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh
+         ENDIF
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         zmfub(i) = MIN(zmfub(i),zmfmax)
+         zentr(i) = ENTRSCV
+         IF (ktype(i).EQ.1) zentr(i) = ENTRPEN
+      ENDDO
+C-----------------------------------------------------------------------
+C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+C-----------------------------------------------------------------------
+c (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+c     considerer l'entrainement ni le detrainement du panache, sachant
+c     ces derniers peuvent abaisser la hauteur theorique.
+c
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb)
+         ictop0(i)=kcbot(i)-1
+      ENDDO
+c
+      zalvdcp=RLVTT/RCPD
+      DO k=klev-1,3,-1
+      DO i = 1, klon
+         zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k)
+         zgam=R5LES*zalvdcp*zqsenh(i,k)/
+     .        ((1.-RETV  *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2)
+         zzz=RCPD*ztenh(i,k)*0.608
+         zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)*
+     .               MAX(zqsenh(i,k)-zqenh(i,k),0.)
+         IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k
+      ENDDO
+      ENDDO
+c
+c (B) calculer le panache ascendant
+c
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+      IF (kcum.EQ.0) GO TO 1000
+C
+C verifier l'epaisseur de la convection et changer eventuellement
+c le taux d'entrainement/detrainement
+C
+      DO i = 1, klon
+         zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i))
+         IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2
+         IF(ldcum(i)) ictop0(i)=kctop(i)
+         IF(ktype(i).EQ.2) zentr(i)=ENTRSCV
+      ENDDO
+c
+      IF (lmfdd) THEN  ! si l'on considere le panache descendant
+c
+c calculer la precipitation issue du panache ascendant pour 
+c determiner l'existence du panache descendant dans la convection
+      DO i = 1, klon
+         zrfl(i)=zdmfup(i,1)
+      ENDDO
+      DO k=2,klev
+      DO i = 1, klon
+         zrfl(i)=zrfl(i)+zdmfup(i,k)
+      ENDDO
+      ENDDO
+c
+c determiner le LFS (level of free sinking: niveau de plonge libre)
+      CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu,
+     *     ldcum,    kcbot,    kctop,    zmfub,    zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     kdtop,    lddraf)
+c
+c calculer le panache descendant
+      CALL flxddraf(ztenh,    zqenh,
+     *     zgeoh,    paph,     zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     lddraf, pen_d, pde_d)
+c
+c calculer de nouveau le flux de masse entrant a travers la base
+c de la convection, sachant qu'il a ete modifie par le panache
+c descendant
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         ikb = kcbot(i)
+         llo1 = PMFD(i,ikb).LT.0.
+         zeps = 0.
+         IF ( llo1 ) zeps = CMFDEPS
+         zqumqe = pqu(i,ikb)+plu(i,ikb)-
+     .            zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb)
+         zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10)
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)
+     .       .AND.zmfub(i).LT.zmfmax) THEN
+            zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub1(i) = zmfub(i)
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)-
+     .            (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh
+         ENDIF
+         IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND.
+     .              ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) )
+     .      zmfub1(i) = zmfub(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         zfac = zmfub1(i)/MAX(zmfub(i),1.E-10)
+         pmfd(i,k) = pmfd(i,k)*zfac
+         zmfds(i,k) = zmfds(i,k)*zfac
+         zmfdq(i,k) = zmfdq(i,k)*zfac
+         zdmfdp(i,k) = zdmfdp(i,k)*zfac
+         pen_d(i,k) = pen_d(i,k)*zfac
+         pde_d(i,k) = pde_d(i,k)*zfac
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (lddraf(i)) zmfub(i)=zmfub1(i)
+      ENDDO
+c
+      ENDIF   ! fin de test sur lmfdd
+c
+c-----------------------------------------------------------------------
+c calculer de nouveau le panache ascendant
+c-----------------------------------------------------------------------
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+c
+c-----------------------------------------------------------------------
+c determiner les flux convectifs en forme finale, ainsi que
+c la quantite des precipitations
+c-----------------------------------------------------------------------
+      CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, 
+     .     ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum,
+     .     pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude,
+     .     zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2,
+     .     pmflxr, pmflxs)
+c
+c----------------------------------------------------------------------
+c calculer les tendances pour T et Q
+c----------------------------------------------------------------------
+      CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten,
+     e     zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel,
+     s     dt_con,dq_con)
+c
+ 1000 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh,
+     .           pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq,
+     .           pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude,
+     .           klab,pen_u, pde_u, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+C AND INITIALIZES VALUES FOR UPDRAFTS
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pten(klon,klev)   ! temperature (environnement)
+      REAL pqen(klon,klev)   ! humidite (environnement)
+      REAL pqsen(klon,klev)  ! humidite saturante (environnement)
+      REAL pgeo(klon,klev)   ! geopotentiel (g * metre)
+      REAL pgeoh(klon,klev)  ! geopotentiel aux demi-niveaux
+      REAL paph(klon,klev+1) ! pression aux demi-niveaux
+      REAL ptenh(klon,klev)  ! temperature aux demi-niveaux
+      REAL pqenh(klon,klev)  ! humidite aux demi-niveaux
+      REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux
+C
+      REAL ptu(klon,klev)    ! temperature du panache ascendant (p-a)
+      REAL pqu(klon,klev)    ! humidite du p-a
+      REAL plu(klon,klev)    ! eau liquide du p-a
+      REAL pmfu(klon,klev)   ! flux de masse du p-a
+      REAL pmfus(klon,klev)  ! flux de l'energie seche dans le p-a
+      REAL pmfuq(klon,klev)  ! flux de l'humidite dans le p-a
+      REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a
+      REAL plude(klon,klev)  ! quantite de l'eau liquide jetee du
+c                              p-a a l'environnement
+      REAL pdpmel(klon,klev) ! quantite de neige fondue
+c
+      REAL ptd(klon,klev)    ! temperature du panache descendant (p-d)
+      REAL pqd(klon,klev)    ! humidite du p-d
+      REAL pmfd(klon,klev)   ! flux de masse du p-d
+      REAL pmfds(klon,klev)  ! flux de l'energie seche dans le p-d
+      REAL pmfdq(klon,klev)  ! flux de l'humidite dans le p-d
+      REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d
+c
+      REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a
+      REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a
+      REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d
+      REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d
+C
+      INTEGER  klab(klon,klev)
+      LOGICAL  llflag(klon)
+      INTEGER k, i, icall
+      REAL zzs
+C----------------------------------------------------------------------
+C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+C----------------------------------------------------------------------
+      DO 130 k = 2, klev
+c
+      DO i = 1, klon
+         pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5
+         ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1),
+     .             RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD
+         pqsenh(i,k)=pqsen(i,k-1)
+         llflag(i)=.TRUE.
+      ENDDO
+c
+      icall=0
+      CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall)
+c
+      DO i = 1, klon
+         pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1))
+     .               +(pqsenh(i,k)-pqsen(i,k-1))
+         pqenh(i,k)=MAX(pqenh(i,k),0.)
+      ENDDO
+c
+  130 CONTINUE
+C
+      DO 140 i = 1, klon
+         ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)-
+     1                   pgeoh(i,klev))/RCPD
+         pqenh(i,klev)=pqen(i,klev)
+         ptenh(i,1)=pten(i,1)
+         pqenh(i,1)=pqen(i,1)
+         pgeoh(i,1)=pgeo(i,1)
+  140 CONTINUE
+c
+      DO 160 k = klev-1, 2, -1
+      DO 150 i = 1, klon
+         zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k),
+     .             RCPD*ptenh(i,k+1)+pgeoh(i,k+1))
+         ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD
+  150 CONTINUE
+  160 CONTINUE
+C
+C-----------------------------------------------------------------------
+C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+C-----------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         ptu(i,k) = ptenh(i,k)
+         pqu(i,k) = pqenh(i,k)
+         plu(i,k) = 0.
+         pmfu(i,k) = 0.
+         pmfus(i,k) = 0.
+         pmfuq(i,k) = 0.
+         pdmfup(i,k) = 0.
+         pdpmel(i,k) = 0.
+         plude(i,k) = 0.
+c
+         klab(i,k) = 0
+c
+         ptd(i,k) = ptenh(i,k)
+         pqd(i,k) = pqenh(i,k)
+         pmfd(i,k) = 0.0
+         pmfds(i,k) = 0.0
+         pmfdq(i,k) = 0.0
+         pdmfdp(i,k) = 0.0
+c
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph,
+     *     ptu, pqu, plu, ldcum, kcbot, klab)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+C
+C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+C   klab=1 FOR SUBCLOUD LEVELS
+C   klab=2 FOR CONDENSATION LEVEL
+C
+C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C       ----------------------------------------------------------------
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      INTEGER  klab(klon,klev), kcbot(klon)
+C
+      LOGICAL llflag(klon), ldcum(klon)
+      INTEGER i, k, icall, is
+      REAL zbuo, zqold(klon)
+C----------------------------------------------------------------------
+C INITIALIZE VALUES AT LIFTING LEVEL
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,klev)=1
+         kcbot(i)=klev-1
+         ldcum(i)=.FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C DO ASCENT IN SUBCLOUD LAYER,
+C CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+C ADJUST T,Q AND L ACCORDINGLY
+C CHECK FOR BUOYANCY AND SET FLAGS
+C----------------------------------------------------------------------
+      DO 290 k = klev-1, 2, -1
+c
+      is = 0
+      DO i = 1, klon
+         IF (klab(i,k+1).EQ.1) is = is + 1
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+      DO i = 1, klon
+      IF(llflag(i)) THEN
+         pqu(i,k) = pqu(i,k+1)
+         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k) = 1
+         zqold(i) = pqu(i,k)
+      ENDIF
+      ENDDO
+c
+      icall=1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+c
+      DO i = 1, klon
+      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) kcbot(i) = k
+         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+  290 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen,
+     .     pgeo, pgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, klab, ptu, pqu, plu,
+     .     pmfu, pmfub, pentr, pmfus, pmfuq,
+     .     pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum,
+     .     pen_u, pde_u)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+C FOR CUMULUS PARAMETERIZATION
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL pdtime
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pgeo(klon,klev), pgeoh(klon,klev)
+      REAL pap(klon,klev), paph(klon,klev+1)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev) ! vitesse verticale en Pa/s
+C
+      REAL pmfub(klon), pentr(klon)
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pdmfup(klon,klev)
+      INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon)
+      INTEGER kctop0(klon)
+      LOGICAL ldland(klon), ldcum(klon)
+C
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL zqold(klon)
+      REAL zdland(klon)
+      LOGICAL llflag(klon)
+      INTEGER k, i, is, icall, kcum
+      REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+      REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+c
+      REAL zpbot(klon), zptop(klon), zrho(klon)
+      REAL zdprho, zentr, zpmid, zmftest, zmfmax
+      LOGICAL llo1, llo2
+c
+      REAL zwmax(klon), zzzmb
+      INTEGER klwmin(klon) ! level of maximum vertical velocity
+C----------------------------------------------------------------------
+      ztglace = RTT - 13.
+c
+c Chercher le niveau ou la vitesse verticale est maximale:
+      DO i = 1, klon
+         klwmin(i) = klev
+         zwmax(i) = 0.0
+      ENDDO
+      DO k = klev, 3, -1
+      DO i = 1, klon
+      IF (pvervel(i,k).LT.zwmax(i)) THEN
+         zwmax(i) = pvervel(i,k)
+         klwmin(i) = k
+      ENDIF
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+C SET DEFAULT VALUES
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (.NOT.ldcum(i)) ktype(i)=0
+      ENDDO
+c
+      DO k=1,klev
+      DO i = 1, klon
+         plu(i,k)=0.
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         plude(i,k)=0.
+         pdmfup(i,k)=0.
+         IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0
+         IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (ldland(i)) THEN
+         zdland(i)=3.0E4
+         zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i))
+         IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi
+         zdland(i)=MAX(3.0E4,zdland(i))
+         zdland(i)=MIN(5.0E4,zdland(i))
+      ENDIF
+      ENDDO
+C
+C Initialiser les valeurs au niveau d'ascendance
+C
+      DO i = 1, klon
+         kctop(i) = klev-1
+         IF (.NOT.ldcum(i)) THEN
+            kcbot(i) = klev-1
+            pmfub(i) = 0.
+            pqu(i,klev) = 0.
+         ENDIF
+         pmfu(i,klev) = pmfub(i)
+         pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev))
+         pmfuq(i,klev) = pmfub(i)*pqu(i,klev)
+      ENDDO
+c
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C  DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+C  BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+C  BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+C  THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+C----------------------------------------------------------------------
+      DO 480 k = klev-1,3,-1
+c
+      IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN
+         DO i = 1, klon
+         IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND.
+     .       pqen(i,k).GT.0.9*pqsen(i,k)) THEN
+            ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD
+            pqu(i,k+1) = pqen(i,k)
+            plu(i,k+1) = 0.0
+            zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG)
+            zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime)
+            pmfub(i) = MIN(zzzmb,zmfmax)
+            pmfu(i,k+1) = pmfub(i)
+            pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1))
+            pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1)
+            pmful(i,k+1) = 0.0
+            pdmfup(i,k+1) = 0.0
+            kcbot(i) = k
+            klab(i,k+1) = 1
+            ktype(i) = 3
+            pentr(i) = ENTRMID
+         ENDIF
+         ENDDO
+      ENDIF
+c
+      is = 0
+      DO i = 1, klon
+         is = is + klab(i,k+1)
+         IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE.
+      ENDDO
+      IF (is .EQ. 0) GOTO 480
+c
+c calculer le taux d'entrainement et de detrainement
+c
+      DO i = 1, klon
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1))
+         zpbot(i)=paph(i,kcbot(i))
+         zptop(i)=paph(i,kctop0(i))
+      ENDDO
+c
+      DO 125 i = 1, klon
+      IF(ldcum(i)) THEN
+         zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i))
+         zentr=pentr(i)*pmfu(i,k+1)*zdprho
+         llo1=k.LT.kcbot(i)
+         IF(llo1) pde_u(i,k)=zentr
+         zpmid=0.5*(zpbot(i)+zptop(i))
+         llo2=llo1.AND.ktype(i).EQ.2.AND.
+     .        (zpbot(i)-paph(i,k).LT.0.2E5.OR.
+     .         paph(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND.
+     .        (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2)
+         IF(llo1) THEN
+            zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4)))
+            pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+            pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+         ENDIF
+         IF(llo2.AND.pqenh(i,k+1).GT.1.E-5)
+     .   pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)*
+     .              zrho(i)*zdprho
+      ENDIF
+  125 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+C----------------------------------------------------------------------
+c
+      DO 420 i = 1, klon
+      IF (llflag(i)) THEN
+         IF (k.LT.kcbot(i)) THEN
+            zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+            zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime))
+            pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0)
+         ENDIF
+         pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1))
+c calculer le flux de masse du niveau k a partir de celui du k+1
+         pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+c calculer les valeurs Su, Qu et l du niveau k dans le panache montant
+         zqeen=pqenh(i,k+1)*pen_u(i,k)
+         zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k)
+         zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k)
+         zqude=pqu(i,k+1)*pde_u(i,k)
+         plude(i,k)=plu(i,k+1)*pde_u(i,k)
+         zmfusk=pmfus(i,k+1)+zseen-zscde
+         zmfuqk=pmfuq(i,k+1)+zqeen-zqude
+         zmfulk=pmful(i,k+1)    -plude(i,k)
+         plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))-
+     1               pgeoh(i,k))/RCPD
+         ptu(i,k)=MAX(100.,ptu(i,k))
+         ptu(i,k)=MIN(400.,ptu(i,k))
+         zqold(i)=pqu(i,k)
+      ELSE
+         zqold(i)=0.0
+      ENDIF
+  420 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+C----------------------------------------------------------------------
+c
+      icall = 1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+C
+      DO 440 i = 1, klon
+      IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))
+         IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5
+         IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN
+            kctop(i) = k
+            ldcum(i) = .TRUE.
+            zdnoprc = 1.5E4
+            IF (ldland(i)) zdnoprc = zdland(i)
+            zprcon = CPRCON
+            IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0
+            zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+            pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+            plu(i,k)=zlnew
+         ELSE
+            klab(i,k)=0
+            pmfu(i,k)=0.
+         ENDIF
+      ENDIF
+  440 CONTINUE
+      DO 455 i = 1, klon
+      IF (llflag(i)) THEN
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+      ENDIF
+  455 CONTINUE
+C
+  480 CONTINUE
+C----------------------------------------------------------------------
+C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+C    (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+C           AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+C           FROM PREVIOUS CALCULATIONS ABOVE)
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE.
+         kcbot(i) = MAX(kcbot(i),kctop(i))
+      ENDDO
+c
+      ldcum(1)=ldcum(1)
+c
+      is = 0
+      DO i = 1, klon
+         if (ldcum(i)) is = is + 1
+      ENDDO
+      kcum = is
+      IF (is.EQ.0) GOTO 800
+c
+      DO 530 i = 1, klon
+      IF (ldcum(i)) THEN
+         k=kctop(i)-1
+         pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1)
+         plude(i,k)=pde_u(i,k)*plu(i,k+1)
+         pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k)
+         zlnew=plu(i,k)
+         pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+         plu(i,k)=zlnew
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         plude(i,k-1)=pmful(i,k)
+      ENDIF
+  530 CONTINUE
+C
+  800 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap
+     .  ,  paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop
+     .  ,  ktype, ldcum, pmfu, pmfd, pmfus, pmfds
+     .  ,  pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp
+     .  ,  pten, prfl, psfl, pdpmel, ktopm2
+     .  ,  pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL cevapcu(klon,klev)
+C     -----------------------------------------------------------------
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL paph(klon,klev+1), pgeoh(klon,klev)
+c
+      REAL pap(klon,klev)
+      REAL ztmsmlt, zdelta, zqsat
+C
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfdq(klon,klev)
+      REAL plude(klon,klev)
+      REAL pdmfup(klon,klev), pdpmel(klon,klev)
+cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+cjq 14/11/00 to fix the problem with the negative precipitation.      
+      REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) 
+      REAL prfl(klon), psfl(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+      INTEGER k, kp, i
+      REAL zcons1, zcons2, zcucov, ztmelp2
+      REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+      REAL zrmin, zrfln, zdrfl
+      REAL zpds, zpdr, zdenom
+      INTEGER ktopm2, itop, ikb
+c
+      LOGICAL lddraf(klon)
+      INTEGER kdtop(klon)
+c
+#include "FCTTRE.h"
+c
+      DO 101 k=1,klev
+        DO i=1,klon
+      CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293)
+     1 *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG
+        ENDDO
+ 101  CONTINUE
+c
+c SPECIFY CONSTANTS
+c
+      zcons1 = RCPD/(RLMLT*RG*pdtime)
+      zcons2 = 1./(RG*pdtime)
+      zcucov = 0.05
+      ztmelp2 = RTT + 2.
+c
+c DETERMINE FINAL CONVECTIVE FLUXES
+c
+      itop=klev
+      DO 110 i = 1, klon
+         itop=MIN(itop,kctop(i))
+         IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE.
+         IF(.NOT.ldcum(i)) ktype(i)=0
+  110 CONTINUE
+c
+      ktopm2=itop-2
+      DO 120 k=ktopm2,klev
+      DO 115 i = 1, klon
+      IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN
+         pmfus(i,k)=pmfus(i,k)-pmfu(i,k)*
+     .                (RCPD*ptenh(i,k)+pgeoh(i,k))
+         pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k)
+         zdp = 1.5E4
+         IF ( ldland(i) ) zdp = 3.E4
+c
+c        l'eau liquide detrainee est precipitee quand certaines
+c        conditions sont reunies (sinon, elle est consideree
+c        evaporee dans l'environnement)
+c
+         IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND.
+     .      pqen(i,k-1).GT.0.8*pqsen(i,k-1))
+     .      pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1)
+c
+         IF(lddraf(i).AND.k.GE.kdtop(i)) THEN
+            pmfds(i,k)=pmfds(i,k)-pmfd(i,k)*
+     .                   (RCPD*ptenh(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k)
+         ELSE
+            pmfd(i,k)=0.
+            pmfds(i,k)=0.
+            pmfdq(i,k)=0.
+            pdmfdp(i,k-1)=0.
+         END IF
+      ELSE
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         pdmfup(i,k-1)=0.
+         plude(i,k-1)=0.
+         pmfd(i,k)=0.
+         pmfds(i,k)=0.
+         pmfdq(i,k)=0.
+         pdmfdp(i,k-1)=0.
+      ENDIF
+  115 CONTINUE
+  120 CONTINUE
+c
+      DO 130 k=ktopm2,klev
+      DO 125 i = 1, klon
+      IF(ldcum(i).AND.k.GT.kcbot(i)) THEN
+         ikb=kcbot(i)
+         zzp=((paph(i,klev+1)-paph(i,k))/
+     .        (paph(i,klev+1)-paph(i,ikb)))
+         IF (ktype(i).EQ.3) zzp = zzp**2
+         pmfu(i,k)=pmfu(i,ikb)*zzp
+         pmfus(i,k)=pmfus(i,ikb)*zzp
+         pmfuq(i,k)=pmfuq(i,ikb)*zzp
+         pmful(i,k)=pmful(i,ikb)*zzp
+      ENDIF
+  125 CONTINUE
+  130 CONTINUE
+c
+c CALCULATE RAIN/SNOW FALL RATES
+c CALCULATE MELTING OF SNOW
+c CALCULATE EVAPORATION OF PRECIP
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,k) = 0.0
+         pmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i)) THEN
+         IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN
+            zfac=zcons1*(paph(i,k+1)-paph(i,k))
+            zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2))
+            pdpmel(i,k)=zsnmlt
+            ztmsmlt=pten(i,k)-zsnmlt/zfac
+            zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt))
+            zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k)
+            zqsat=MIN(0.5,zqsat)
+            zqsat=zqsat/(1.-RETV  *zqsat)
+            pqsen(i,k) = zqsat
+         ENDIF
+         IF (pten(i,k).GT.RTT) THEN
+         pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k)
+         ELSE
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)
+           pmflxr(i,k+1)=pmflxr(i,k)
+         ENDIF
+c        si la precipitation est negative, on ajuste le plux du
+c        panache descendant pour eliminer la negativite
+         IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN
+            pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k)
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cjq The new variable is initialized here.
+cjq It contains the humidity which is fed to the downdraft
+cjq by evaporation of precipitation in the column below the base
+cjq of convection.
+cjq 
+cjq In the former version, this term has been subtracted from precip
+cjq as well as the evaporation.
+cjq      
+      DO k = 1, klev
+      DO i = 1, klon 
+         maxpdmfdp(i,k)=0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+       DO kp = k, klev
+        DO i = 1, klon
+         maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp)
+        ENDDO
+       ENDDO
+      ENDDO
+cjq End of initialization
+c      
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN
+         zrfl = pmflxr(i,k) + pmflxs(i,k)
+         IF (zrfl.GT.1.0E-20) THEN
+            zrnew=(MAX(0.,SQRT(zrfl/zcucov)-
+     .            CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))*
+     .            MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov
+            zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k))
+     .            *zcons2*(paph(i,k+1)-paph(i,k))
+            zrnew=MAX(zrnew,zrmin)
+            zrfln=MAX(zrnew,0.)
+            zdrfl=MIN(0.,zrfln-zrfl)
+cjq At least the amount of precipiation needed to feed the downdraft
+cjq with humidity below the base of convection has to be left and can't
+cjq be evaporated (surely the evaporation can't be positive):            
+            zdrfl=MAX(zdrfl,
+     .            MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0))
+cjq End of insertion
+c            
+            zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k))
+            IF (pten(i,k).GT.RTT) THEN
+               zpdr = pdmfdp(i,k)
+               zpds = 0.0
+            ELSE
+               zpdr = 0.0
+               zpds = pdmfdp(i,k)
+            ENDIF
+            pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k)
+     .                    + zdrfl*pmflxr(i,k)*zdenom
+            pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k)
+     .                    + zdrfl*pmflxs(i,k)*zdenom
+            pdmfup(i,k) = pdmfup(i,k) + zdrfl
+         ELSE
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdmfdp(i,k) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) 
+     .    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 210 i = 1, klon
+         prfl(i) = pmflxr(i,klev+1)
+         psfl(i) = pmflxs(i,klev+1)
+  210 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten
+     .  ,  pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp
+     .  ,  pdpmel, dt_con, dq_con)
+      USE dimphy
+      IMPLICIT none
+c----------------------------------------------------------------------
+c calculer les tendances T et Q
+c----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     -----------------------------------------------------------------
+      LOGICAL  llo1
+C
+      REAL pten(klon,klev), paph(klon,klev+1)
+      REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfup(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL pdpmel(klon,klev)
+      LOGICAL ldcum(klon)
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+c
+      INTEGER ktopm2
+      REAL pdtime
+c
+      INTEGER i, k
+      REAL zalv, zdtdt, zdqdt
+c
+      DO 210 k=ktopm2,klev-1
+      DO 220 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .        *(pmfus(i,k+1)-pmfus(i,k)
+     .         +pmfds(i,k+1)-pmfds(i,k)
+     .          -RLMLT*pdpmel(i,k)
+     .          -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+     .         )
+         dt_con(i,k)=zdtdt
+         zdqdt=RG/(paph(i,k+1)-paph(i,k))
+     .        *(pmfuq(i,k+1)-pmfuq(i,k)
+     .         +pmfdq(i,k+1)-pmfdq(i,k)
+     .          +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  220 CONTINUE
+  210 CONTINUE
+C
+      k = klev
+      DO 230 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .         *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k)
+     .           -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+         dt_con(i,k)=zdtdt
+         zdqdt=-RG/(paph(i,k+1)-paph(i,k))
+     .            *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)
+     .             +pdmfup(i,k)+pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  230 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu,
+     .     ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd,
+     .     pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+C
+C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+C FOR MASSFLUX CUMULUS PARAMETERIZATION
+C
+C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+C AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+C
+C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+C MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev)
+      REAL pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+      REAL ptu(klon,klev), pqu(klon,klev)
+      REAL pmfub(klon)
+      REAL prfl(klon)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      INTEGER  kcbot(klon), kctop(klon), kdtop(klon)
+      LOGICAL  ldcum(klon), lddraf(klon)
+C
+      REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon)
+      REAL zttest, zqtest, zbuo, zmftop
+      LOGICAL  llo2(klon)
+      INTEGER i, k, is, icall
+C----------------------------------------------------------------------
+      DO i= 1, klon
+         lddraf(i)=.FALSE.
+         kdtop(i)=klev+1
+      ENDDO
+C
+C----------------------------------------------------------------------
+C DETERMINE LEVEL OF FREE SINKING BY
+C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+C
+C FOR EVERY POINT AND PROCEED AS FOLLOWS:
+C     (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+C     (2) DO MIXING WITH CUMULUS CLOUD AIR
+C     (3) CHECK FOR NEGATIVE BUOYANCY
+C
+C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+C EVAPORATION OF RAIN AND CLOUD WATER)
+C----------------------------------------------------------------------
+C
+      DO 290 k = 3, klev-3
+C
+      is=0
+      DO 212 i= 1, klon
+         ztenwb(i,k)=ptenh(i,k)
+         zqenwb(i,k)=pqenh(i,k)
+         llo2(i) = ldcum(i).AND.prfl(i).GT.0.
+     .             .AND..NOT.lddraf(i)
+     .             .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i))
+         IF ( llo2(i) ) is = is + 1
+  212 CONTINUE
+      IF(is.EQ.0) GO TO 290
+C
+      icall=2
+      CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+C
+C----------------------------------------------------------------------
+C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+C AND CHECK FOR NEGATIVE BUOYANCY.
+C THEN SET VALUES FOR DOWNDRAFT AT LFS.
+C----------------------------------------------------------------------
+      DO 222 i= 1, klon
+      IF (llo2(i)) THEN
+         zttest=0.5*(ptu(i,k)+ztenwb(i,k))
+         zqtest=0.5*(pqu(i,k)+zqenwb(i,k))
+         zbuo=zttest*(1.+RETV*zqtest)-
+     .        ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         zcond(i)=pqenh(i,k)-zqenwb(i,k)
+         zmftop=-CMFDEPS*pmfub(i)
+         IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN
+            kdtop(i)=k
+            lddraf(i)=.TRUE.
+            ptd(i,k)=zttest
+            pqd(i,k)=zqtest
+            pmfd(i,k)=zmftop
+            pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfd(i,k)*pqd(i,k)
+            pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i)
+            prfl(i)=prfl(i)+pdmfdp(i,k-1)
+         ENDIF
+      ENDIF
+  222 CONTINUE
+c
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl,
+     .           ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp,
+     .           lddraf, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+C
+C          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+C          (I.E. T,Q,U AND V AND FLUXES)
+C
+C          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+C          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+C          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+C
+C          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+C          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+C          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+C
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon)
+      LOGICAL lddraf(klon)
+C
+      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
+      LOGICAL llo2(klon), llo1
+      INTEGER i, k, is, icall, itopde
+      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+      REAL zbuo
+C----------------------------------------------------------------------
+C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+C       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+C           LINEAR DECREASE OF MASSFLUX IN PBL
+C       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+C           AND MOISTENING IS CALCULATED IN *flxadjtq*
+C       (C) CHECKING FOR NEGATIVE BUOYANCY AND
+C           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+C
+      DO 180 k = 3, klev
+c
+      is = 0
+      DO i = 1, klon
+         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
+         IF (llo2(i)) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 180
+c
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/
+     .           (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
+         pen_d(i,k) = zentr
+         pde_d(i,k) = zentr
+      ENDIF
+      ENDDO
+c
+      itopde = klev-2
+      IF (k.GT.itopde) THEN
+         DO i = 1, klon
+         IF (llo2(i)) THEN
+            pen_d(i,k)=0.
+            pde_d(i,k)=pmfd(i,itopde)*
+     .      (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
+         ENDIF
+         ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
+         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
+         zqeen = pqenh(i,k-1)*pen_d(i,k)
+         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
+         zqdde = pqd(i,k-1)*pde_d(i,k)
+         zmfdsk = pmfds(i,k-1)+zseen-zsdde
+         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
+         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
+         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))-
+     .               pgeoh(i,k))/RCPD
+         ptd(i,k) = MIN(400.,ptd(i,k))
+         ptd(i,k) = MAX(100.,ptd(i,k))
+         zcond(i) = pqd(i,k)
+      ENDIF
+      ENDDO
+C
+      icall = 2
+      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zcond(i) = zcond(i)-pqd(i,k)
+         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))-
+     .          ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
+         IF (.not.llo1) pmfd(i,k) = 0.0
+         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
+         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
+         zdmfdp = -pmfd(i,k)*zcond(i)
+         pdmfdp(i,k-1) = zdmfdp
+         prfl(i) = prfl(i)+zdmfdp
+      ENDIF
+      ENDDO
+c
+  180 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Objet: ajustement entre T et Q
+c======================================================================
+C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+C        kcall=0    ENV. T AND QS IN*CUINI*
+C        kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL ldflag(klon)
+      INTEGER kcall
+c
+      REAL zcond(klon), zcond1
+      REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      z5alvcp = r5les*RLVTT/RCPD
+      z5alscp = r5ies*RLSTT/RCPD
+      zalvdcp = rlvtt/RCPD
+      zalsdcp = rlstt/RCPD
+C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
+      DO 210 i =1, klon
+      IF (ldflag(i)) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond(i) = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor))
+         IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.)
+         IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.)
+         pt(i) = pt(i) + zldcp*zcond(i)
+         pq(i) = pq(i) - zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i =1, klon
+         IF (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(ldflag(i).AND.zcond(i).NE.0.) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond1 = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor))
+         pt(i) = pt(i) + zldcp*zcond1
+         pq(i) = pq(i) - zcond1
+      ENDIF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxsetup
+      IMPLICIT none
+C
+C     THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+C
+#include "YOECUMF.h"
+C
+      ENTRPEN=1.0E-4  ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+      ENTRSCV=3.0E-4  ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+      ENTRMID=1.0E-4  ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+      ENTRDD =2.0E-4  ! ENTRAINMENT RATE FOR DOWNDRAFTS
+      CMFCTOP=0.33  ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+      CMFCMAX=1.0  ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+      CMFCMIN=1.E-10  ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+      CMFDEPS=0.3  ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+      CPRCON =2.0E-4  ! CONVERSION FROM CLOUD WATER TO RAIN
+      RHCDD=1.  ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+c                 (FORMULATION IMPLIES SATURATION)
+      LMFPEN = .TRUE.
+      LMFSCV = .TRUE.
+      LMFMID = .TRUE.
+      LMFDD = .TRUE.
+      LMFDUDV = .TRUE.
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conlmd.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conlmd.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/conlmd.F	(revision 984)
@@ -0,0 +1,2321 @@
+!
+! $Header$
+!
+      SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q,
+     s                   d_t, d_q, rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection utilis'e dans le modele du LMD
+c        Ajustement humide (Manabe) + Ajustement convectif (Kuo)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql(klon,klev), d_ql_bis(klon,klev)
+      REAL rneb(klon,klev), rneb_bis(klon,klev)
+c
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+ccc      CALL fiajh ! ancienne version de Convection Manabe
+      CALL conman ! nouvelle version de Convection Manabe
+     e     (dtime, paprs, pplay, t, q,
+     s      d_t, d_q, d_ql, rneb,
+     s      rain, snow, ibas, itop)
+c
+      IF (usekuo) THEN
+ccc      CALL fiajc ! ancienne version de Convection Kuo
+      CALL conkuo ! nouvelle version de Convection Kuo
+     e     (dtime, paprs, pplay, t, q, conv_q,
+     s      d_t_bis, d_q_bis, d_ql_bis, rneb_bis, 
+     s      rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+         d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         ibas(i) = MIN(ibas(i),ibas_bis(i))
+         itop(i) = MAX(itop(i),itop_bis(i))
+      ENDDO
+      ENDIF
+c
+c L'eau liquide convective est dispersee dans l'air:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE conman (dtime, paprs, pplay, t, q,
+     s                   d_t, d_q, d_ql, rneb,
+     s                   rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
+c Objet: ajustement humide convectif avec la possibilite de faire
+c        l'ajustement sur une fraction de la maille.
+c Methode: On impose une distribution uniforme pour la vapeur d'eau
+c au sein d'une maille. On applique la procedure d'ajustement
+c successivement a la totalite, 75%, 50%, 25% et 5% de la maille
+c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
+c les activites convectives et corrige le biais "trop froid et sec"
+c du modele.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL afaire(klon)   ! .TRUE. implique l'ajustement
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
+c
+      INTEGER nb ! nombre de sous-fractions a considere
+      PARAMETER (nb=1)
+ccc      PARAMETER (nb=3)
+c
+      REAL ratqs ! largeur de la distribution pour vapeur d'eau
+      PARAMETER (ratqs=0.05)
+c
+      REAL w_q(klon,klev)
+      REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev)
+      REAL w_rneb(klon,klev)
+      REAL w_rain(klon), w_snow(klon)
+      INTEGER w_ibas(klon), w_itop(klon)
+      REAL zq1, zq2
+      INTEGER i, k, n
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL zdp1, zdp2
+      REAL zqs1, zqs2, zdqs1, zdqs2
+      REAL zgamdz
+      REAL zflo ! flotabilite
+      REAL zsat ! sur-saturation
+      REAL zdelta, zcor, zcvm5
+      LOGICAL imprim
+c
+      INTEGER ncpt
+      SAVE ncpt
+c$OMP THREADPRIVATE(ncpt)
+      REAL frac(nb) ! valeur de la maille fractionnelle
+      SAVE frac
+c$OMP THREADPRIVATE(frac)
+      INTEGER opt_cld(nb) ! option pour le modele nuageux
+      SAVE opt_cld
+c$OMP THREADPRIVATE(opt_cld)
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA frac / 1.0 /
+      DATA opt_cld / 4 /
+ccc      DATA frac    / 1.0, 0.50, 0.25/
+ccc      DATA opt_cld / 4,   4,    4/
+c
+      DATA appel1er /.TRUE./
+      DATA ncpt /0/
+c
+      IF (appel1er) THEN
+         PRINT*, 'conman, nb:', nb
+         PRINT*, 'conman, frac:', frac
+         PRINT*, 'conman, opt_cld:', opt_cld
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c S'il n'y a pas d'instabilite conditionnelle,
+c pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         afaire(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev-1
+      DO i = 1, klon
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+            zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+            zqs1=MIN(0.5,zqs1)
+            zcor=1./(1.-RETV*zqs1)
+            zqs1=zqs1*zcor
+            zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor)
+c
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1))
+            zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1)
+            zqs2=MIN(0.5,zqs2)
+            zcor=1./(1.-RETV*zqs2)
+            zqs2=zqs2*zcor
+            zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor)
+         ELSE
+           IF (t(i,k) .LT. t_coup) THEN
+              zqs1= qsats(t(i,k)) / pplay(i,k)
+              zdqs1= dqsats(t(i,k),zqs1)
+c
+              zqs2= qsats(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsats(t(i,k+1),zqs2)
+           ELSE
+              zqs1= qsatl(t(i,k)) / pplay(i,k)
+              zdqs1= dqsatl(t(i,k),zqs1)
+c
+              zqs2= qsatl(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsatl(t(i,k+1),zqs2)
+           ENDIF
+         ENDIF
+         zdp1 = paprs(i,k) - paprs(i,k+1)
+         zdp2 = paprs(i,k+1) - paprs(i,k+2)
+         zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(t(i,k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)
+     .            +RLVTT*(zqs1*zdp1+zqs2*zdp2)/(zdp1+zdp2)
+     .           ) / (1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2) )
+         zflo = t(i,k) + zgamdz - t(i,k+1)
+         zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
+         IF (zflo.GT.0.0) afaire(i) = .TRUE.
+c erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
+      ENDDO
+      ENDDO
+c
+      imprim = MOD(ncpt,48).EQ.0
+      DO 99999 n = 1, nb
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zq1 = q(i,k) * (1.0-ratqs)
+         zq2 = q(i,k) * (1.0+ratqs)
+         w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      CALL conmanv (dtime, paprs, pplay, t, w_q,
+     e              afaire, opt_cld(n),
+     s              w_d_t, w_d_q, w_d_ql, w_rneb,
+     s              w_rain, w_snow, w_ibas, w_itop,accompli,imprim)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         d_t(i,k) = w_d_t(i,k) * frac(n)
+         d_q(i,k) = w_d_q(i,k) * frac(n)
+         d_ql(i,k) = w_d_ql(i,k) * frac(n)
+         IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n)
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         rain(i) = w_rain(i) * frac(n)
+         snow(i) = w_snow(i) * frac(n)
+         ibas(i) = MIN(ibas(i),w_ibas(i))
+         itop(i) = MAX(itop(i),w_itop(i))
+      ENDIF
+      ENDDO
+      DO i = 1, klon
+         IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
+      ENDDO
+c
+99999 CONTINUE
+c
+      ncpt = ncpt + 1
+c
+      RETURN
+      END
+      SUBROUTINE conmanv (dtime, paprs, pplay, t, q,
+     e                    afaire, opt_cld,
+     s                    d_t, d_q, d_ql, rneb,
+     s                    rain, snow, ibas, itop,accompli,imprim)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement humide (convection proposee par Manabe).
+c        Pour une colonne verticale, il peut avoir plusieurs blocs
+c        necessitant l'ajustement. ibas est le bas du plus bas bloc
+c        et itop est le haut du plus haut bloc
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
+      LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
+c
+c Quelques options:
+c
+      LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
+      PARAMETER (new_top=.FALSE.)
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+      LOGICAL old_tau ! implique precip nulle, si vrai.
+      PARAMETER (old_tau=.FALSE.)
+      REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+      REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+      PARAMETER (dpmin=0.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
+      LOGICAL exigent ! implique un calcul supplementaire pour Qs
+      PARAMETER (exigent=.FALSE.)
+c
+      INTEGER kbase
+      PARAMETER (kbase=0)
+c
+c Variables locales:
+c
+      INTEGER nexpo
+      INTEGER i, k, k1min, k1max, k2min, k2max, is
+      REAL zgamdz(klon,klev-1)
+      REAL zt(klon,klev), zq(klon,klev)
+      REAL zqs(klon,klev), zdqs(klon,klev)
+      REAL zqmqsdp(klon,klev)
+      REAL ztnew(klon,klev), zqnew(klon,klev)
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zsat(klon) ! sur-saturation
+      REAL zflo(klon) ! flotabilite
+      REAL za(klon), zb(klon), zc(klon)
+      INTEGER k1(klon), k2(klon)
+      REAL zdelta, zcor, zcvm5
+      REAL delp(klon,klev)
+      LOGICAL possible(klon), todo(klon), etendre(klon)
+      LOGICAL aller(klon), todobis(klon)
+      REAL zalfa
+      INTEGER nbtodo, nbdone
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k) - paprs(i,k+1)
+      ENDDO
+      ENDDO
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+         accompli(i) = .FALSE.
+      ENDDO
+c
+c Preparations
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zt(i,k) = t(i,k)
+         zq(i,k) = q(i,k) 
+c
+c        Calculer Qs et L/Cp*dQs/dT
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+c
+c        Calculer (q-qs)*dp
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c-----zgama is the moist convective lapse rate (-dT/dz).
+c-----zgamdz(*,k) est la difference minimale autorisee des temperatures
+c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
+c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c On cherche la presence simultanee d'instabilite conditionnelle
+c et de sur-saturation. Sinon, pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (possible(i)) THEN
+         k1(i) = kbase
+         k2(i) = k1(i) + 1
+      ENDIF
+      ENDDO
+c
+  810 CONTINUE ! chercher le bas de la colonne a ajuster
+c
+      k2min = klev
+      DO i = 1, klon
+         todo(i) = .FALSE.
+         aller(i) = .TRUE.
+         IF (possible(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.EQ.klev) GOTO 860
+      DO k = k2min, klev-1
+      DO i = 1, klon
+      IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            k1(i) = k
+            k2(i) = k+1
+            todo(i) = .TRUE.
+            aller(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (possible(i).AND.aller(i)) THEN
+         todo(i) = .FALSE.
+         k1(i) = klev
+         k2(i) = klev
+      ENDIF
+      ENDDO
+c
+CCC      DO i = 1, klon
+CCC      IF (possible(i)) THEN
+CCC  811    k2(i) = k2(i) + 1
+CCC         IF (k2(i) .GT. klev) THEN
+CCC            todo(i) = .FALSE.
+CCC            GOTO 812
+CCC         ENDIF
+CCC         k = k2(i)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
+CCC         k1(i) = k2(i) - 1
+CCC         todo(i) = .TRUE.
+CCC      ENDIF
+CCC  812 CONTINUE
+CCC      ENDDO
+c
+  820 CONTINUE ! chercher le haut de la colonne
+c
+      k2min = klev
+      DO i = 1, klon
+         aller(i) = .TRUE.
+         IF (todo(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.LT.klev) THEN
+      DO k = k2min, klev
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN
+            zsat(i) = zsat(i) + zqmqsdp(i,k)
+            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+            IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+               aller(i) = .FALSE.
+            ELSE
+               k2(i) = k
+            ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c error      is = 0
+c error      DO i = 1, klon
+c error      IF(todo(i).AND.aller(i)) THEN
+c error         is = is + 1
+c error         todo(i) = .FALSE.
+c error         k2(i) = klev
+c error      ENDIF
+c error      ENDDO
+c error      IF (is.GT.0) THEN
+c error         PRINT*, "Bizard. je pourrais continuer mais j arrete"
+c error         CALL abort
+c error      ENDIF
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (todo(i)) THEN
+CCC  821    CONTINUE
+CCC         IF (k2(i) .EQ. klev) GOTO 822
+CCC         k = k2(i) + 1
+CCC         zsat(i) = zsat(i) + zqmqsdp(i,k)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
+CCC         k2(i) = k
+CCC         GOTO 821
+CCC      ENDIF
+CCC  822 CONTINUE
+CCC      ENDDO
+c
+  830 CONTINUE ! faire l'ajustement en sachant k1 et k2
+c
+      is = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (k2(i).LE.k1(i)) is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         PRINT*, "Impossible: k1 trop grand ou k2 trop petit"
+         PRINT*, "is=", is
+         CALL abort
+      ENDIF
+c
+      k1min = klev
+      k1max = 1
+      k2max = 1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k1min = MIN(k1min,k1(i))
+         k1max = MAX(k1max,k1(i))
+         k2max = MAX(k2max,k2(i))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      k = k1(i)
+      za(i) = 0.
+      zb(i) = ( RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .      -RLVTT*(zqs(i,k)-zq(i,k)) )*delp(i,k)
+      zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         za(i) = za(i) + zgamdz(i,k-1)
+         zb(i) = zb(i)+(RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .           -RLVTT*(zqs(i,k)-zq(i,k)) ) * delp(i,k)
+         zc(i) = zc(i) + delp(i,k)*RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k = k1(i)
+         ztnew(i,k) = zb(i)/zc(i)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                          *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                        *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Quantite de condensation produite pendant l'ajustement:
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         rneb(i,k) = 1.0
+         zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Si condensation negative, effort completement perdu:
+c
+      DO i = 1, klon
+         IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE.
+      ENDDO
+c
+c L'ajustement a ete accompli, meme les calculs accessoires
+c ne sont pas encore faits:
+c
+      DO i = 1, klon
+         IF (todo(i)) accompli(i) = .TRUE.
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1))
+     .                 /paprs(i,1)-dpmin)
+     .                 *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+      ENDIF
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de 
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+            zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k)
+         ENDIF
+         ENDDO
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .      zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k)) 
+     .                          * delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND.
+     .       zvapo(i).GT.0.0)
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,zq(i,k)-zqnew(i,k))
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse 
+         ENDDO                       ! (avec ponderation)
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k) / RG
+     .                    * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre evaporee:
+c
+      zalfa = 0.05
+      IF (evap_prec .AND. (k1max.GE.2)) THEN
+      DO k = k1max-1, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa )
+         zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .         * delp(i,k)/pplay(i,k)*zt(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k)
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime
+         zq(i,k) = zq(i,k) - (zrfln-zrfl(i)) 
+     .                     * (RG/(delp(i,k)))*dtime
+         zt(i,k) = zt(i,k) + (zrfln-zrfl(i))
+     .                     * (RG/(delp(i,k)))*dtime
+     .                     * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k))
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (zt(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+c Mise a jour de la temperature et de l'humidite
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         zt(i,k) = ztnew(i,k)
+         zq(i,k) = zqnew(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Re-calculer certaines variables pour etendre et re-ajuster la colonne
+c
+      IF (exigent) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (exigent) THEN
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Verifier si l'on peut etendre le bas de la colonne
+c
+      DO i = 1, klon
+         etendre(i) = .FALSE.
+      ENDDO
+c
+      k1max = 1
+      DO i = 1, klon
+      IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN
+         k = k1(i)
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+csc voici l'ancienne ligne:
+csc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+csc sylvain: il faut RESPECTER les 2 criteres:
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            etendre(i) = .TRUE.
+            k1(i) = k1(i) - 1
+            k1max = MAX(k1max,k1(i))
+            aller(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+c
+      IF (k1max.GT.(kbase+1)) THEN
+      DO k = k1max, kbase+1, -1
+      DO i = 1, klon
+      IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN
+         zsat(i) = zsat(i) + zqmqsdp(i,k)
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN
+            aller(i) = .FALSE.
+         ELSE
+            k1(i) = k
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (etendre(i).AND.aller(i)) THEN
+            k1(i) = 1
+         ENDIF
+      ENDDO
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (etendre(i)) THEN
+CCC  840    k = k1(i)
+CCC         IF (k.GT.1) THEN
+CCC            zsat(i) = zsat(i) + zqmqsdp(i,k-1)
+CCC            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC            IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+CCC               k1(i) = k - 1
+CCC               GOTO 840
+CCC            ENDIF
+CCC         ENDIF
+CCC      ENDIF
+CCC      ENDDO
+c
+      DO i = 1, klon
+         todobis(i) = todo(i)
+         todo(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (etendre(i)) THEN
+         todo(i) = .TRUE.
+         is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         IF (new_top) THEN
+            GOTO 820 ! chercher de nouveau le sommet k2
+         ELSE
+            GOTO 830 ! supposer que le sommet est celui deja trouve
+         ENDIF
+      ENDIF
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (todobis(i) .AND. k2(i).LT.klev) THEN
+         is = is + 1
+         possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks 
+c     a ajuster a partir du sommet de la colonne precedente
+c
+  860 CONTINUE ! Calculer les tendances et diagnostiques
+ccc      print*, "Apres 860"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (accompli(i)) THEN
+         d_t(i,k) = zt(i,k) - t(i,k)
+         zq(i,k) = MAX(zq(i,k),seuil_vap)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 888 i = 1, klon
+      IF (accompli(i)) THEN
+         DO k = 1, klev
+         IF (rneb(i,k).GT.0.0) THEN
+            ibas(i) = k
+            GOTO 807
+         ENDIF
+         ENDDO
+  807    CONTINUE
+         DO k = klev, 1, -1
+         IF (rneb(i,k).GT.0.0) THEN
+            itop(i) = k
+            GOTO 808
+         ENDIF
+         ENDDO
+  808    CONTINUE
+      ENDIF
+  888 CONTINUE
+c
+      IF (imprim) THEN
+         nbtodo = 0
+         nbdone = 0
+         DO i = 1, klon
+            IF (afaire(i)) nbtodo = nbtodo + 1
+            IF (accompli(i)) nbdone = nbdone + 1
+         ENDDO
+         PRINT*, "nbTodo, nbDone=", nbtodo, nbdone
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s                  d_t, d_q, d_ql, rneb, 
+     s                  rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection de type Kuo (1965).
+c        Cette version du code peut calculer le niveau de depart
+c N.B. version vectorielle (le 6 oct. 1997)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime               ! intervalle du temps (s)
+      REAL paprs(klon,klev+1)  ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)    ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)        ! temperature (K)
+      REAL q(klon,klev)        ! humidite specifique
+      REAL conv_q(klon,klev)   ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)      ! incrementation temperature
+      REAL d_q(klon,klev)      ! incrementation humidite
+      REAL d_ql(klon,klev)     ! incrementation eau liquide
+      REAL rneb(klon,klev)     ! nebulosite
+      REAL rain(klon)          ! pluies (mm/s)
+      REAL snow(klon)          ! neige (mm/s)
+      INTEGER itop(klon)       ! niveau du sommet
+      INTEGER ibas(klon)       ! niveau du bas
+c
+      LOGICAL ldcum(klon)      ! convection existe
+      LOGICAL todo(klon)
+c
+c Quelsques options:
+c
+      LOGICAL calcfcl ! calculer le niveau de convection libre
+      PARAMETER (calcfcl=.TRUE.)
+      INTEGER ldepar ! niveau fixe de convection libre
+      PARAMETER (ldepar=4)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      LOGICAL new_deh ! nouvelle facon de calculer dH
+      PARAMETER (new_deh=.FALSE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      LOGICAL old_tau ! implique precipitation nulle
+      PARAMETER (old_tau=.FALSE.)
+      REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+      REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+      PARAMETER (dpmin=0.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
+c
+c Variables locales:
+c
+      INTEGER nexpo
+      LOGICAL nuage(klon)
+      INTEGER i, k, kbmin, kbmax, khmax
+      REAL ztotal(klon,klev), zdeh(klon,klev)
+      REAL zgz(klon,klev)
+      REAL zqs(klon,klev)
+      REAL zdqs(klon,klev)
+      REAL ztemp(klon,klev)
+      REAL zpres(klon,klev)
+      REAL zconv(klon) ! convergence d'humidite
+      REAL zvirt(klon) ! convergence virtuelle d'humidite
+      REAL zfrac(klon) ! fraction convective
+      INTEGER kb(klon), kh(klon)
+c
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zdelta, zcvm5, zcor
+      REAL zvar
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c Fonctions thermodynamiques
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         PRINT*, 'conkuo, calcfcl:', calcfcl
+         IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar
+         PRINT*, 'conkuo, opt_cld:', opt_cld
+         PRINT*, 'conkuo, evap_prec:', evap_prec
+         PRINT*, 'conkuo, new_deh:', new_deh
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (t(i,k).LT.t_coup) THEN
+              zqs(i,k) = qsats(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsats(t(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsatl(t(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer gz (energie potentielle)
+c
+      DO i = 1, klon
+         zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                   * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgz(i,k) = zgz(i,k-1)
+     .            + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                 * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+c Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztotal(i,k) = RCPD*t(i,k) + RLVTT*zqs(i,k) + zgz(i,k)
+      ENDDO
+      ENDDO
+c
+c Determiner le niveau de depart et calculer la difference de
+c l'energie statique humide saturee (ztotal) entre la couche
+c de depart et chaque couche au-dessus.
+c
+      IF (calcfcl) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            zpres(i,k) = pplay(i,k)
+            ztemp(i,k) = t(i,k)
+         ENDDO
+         ENDDO
+         CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            k = kb(i)
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDIF
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+         IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN
+            IF (new_deh) THEN
+               zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+            ELSE
+               zdeh(i,k) = zdeh(i,k-1)
+     .                   + RCPD * (t(i,k-1)-t(i,k))
+     .                   - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                        *(pplay(i,k-1)-pplay(i,k))
+     .                   + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+         ENDIF
+         ENDDO
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            k = ldepar
+            kb(i) = ldepar
+            ldcum(i) = .TRUE.
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDDO
+         DO k = ldepar+1, klev
+         DO i = 1, klon
+         IF (new_deh) THEN
+             zdeh(i,k)  = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+         ELSE
+             zdeh(i,k) = zdeh(i,k-1)
+     .                 + RCPD * (t(i,k-1)-t(i,k))
+     .                 - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                      *(pplay(i,k-1)-pplay(i,k))
+     .                 + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c-----Chercher le sommet du nuage
+c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
+c-----psolpa/RG pres) du bas jusqu'au sommet du nuage.
+c-----Calculer la convergence virtuelle pour que toute la maille 
+c-----deviennt nuageuse (du bas jusqu'au sommet du nuage)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (k.GE.kb(i) .AND. ldcum(i)) THEN
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i) = k
+            zconv(i)=zconv(i)+conv_q(i,k)*dtime
+     .                       *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0
+      ENDDO
+c
+      kbmin = klev
+      kbmax = 0
+      khmax = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         kbmin = MIN(kbmin,kb(i))
+         kbmax = MAX(kbmax,kb(i))
+         khmax = MAX(khmax,kh(i))
+      ENDIF
+      ENDDO
+c
+c-----Calculer la surface couverte par le nuage
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0))
+      ENDIF
+      ENDDO
+c
+c-----Calculs essentiels:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zcond(i) = 0.0
+      ENDIF
+      ENDDO
+      DO k = kbmin, khmax
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+         zvar = zdeh(i,k)/(1.+zdqs(i,k))
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG
+         rneb(i,k) = zfrac(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i) .AND. zcond(i).LT.0.0) THEN
+         PRINT*, 'WARNING: cond. negative (Kuo) ',
+     .            i,kb(i),kh(i), zcond(i)
+         zcond(i) = 0.0
+         DO k = kb(i), kh(i)
+            d_t(i,k) = 0.0
+            d_q(i,k) = 0.0
+         ENDDO
+         todo(i) = .FALSE. ! effort totalement perdu
+      ENDIF
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1))
+     .               /paprs(i,1)-dpmin)
+     .             *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+      ENDIF
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k))
+     .                    * (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND.
+     .                     zvapo(i).GT.0.0) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,-d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG
+     .                    * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre re-evaporee:
+c
+      IF (evap_prec .AND. kbmax.GE.2) THEN
+      DO k = kbmax, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) )
+         zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .       * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*t(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                 /RG/dtime
+         d_q(i,k) = - (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         d_t(i,k) = (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .          * RLVTT/RCPD
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (t(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: calculer le niveau de convection libre
+c        (FCL: Free Convection Level)
+c======================================================================
+c Arguments:
+c pt---input-R- temperature (K)
+c pq---input-R- vapeur d'eau (kg/kg)
+c pg---input-R- geopotentiel (g*z ou z est en metre)
+c pp---input-R- pression (Pa)
+c
+c LDCUM---output-L- Y-t-il la convection
+c kcbot---output-I- Niveau du bas de la convection
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev)
+      INTEGER  kcbot(klon)
+      LOGICAL  LDCUM(klon)
+C
+      REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev)
+      REAL zqold(klon), zbuo
+      INTEGER is, i, k
+c
+c klab=1: on est sous le nuage convectif
+c klab=2: le bas du nuage convectif
+c klab=0: autres couches
+      INTEGER klab(klon,klev)
+c
+c quand lflag=.true., on est sous le nuage, il faut donc appliquer
+c le processus d'elevation.
+      LOGICAL lflag(klon)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         ztu(i,k) = pt(i,k)
+         zqu(i,k) = pq(i,k)
+         zlu(i,k) = 0.0
+         klab(i,k) = 0
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,1)=1
+         kcbot(i)=2
+         LDCUM(i)=.FALSE.
+      ENDDO
+C
+      DO 290 k = 2, klev-1
+c
+      is=0
+      DO i = 1, klon
+         if (klab(i,k-1).EQ.1) is = is + 1
+         lflag(i) = .FALSE.
+         if (klab(i,k-1).EQ.1) lflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+c on eleve le parcel d'air selon l'adiabatique sec
+c
+      DO i = 1, klon
+      IF (lflag(i)) THEN
+         zqu(i,k) = zqu(i,k-1)
+         ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k)=1
+         zqold(i) = zqu(i,k)
+      ENDIF
+      ENDDO
+c
+c on calcule la condensation eventuelle
+c
+      CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
+c
+c s'il y a la condensation et la "buoyancy" force est positive
+c c'est bien le bas de la tour de convection
+c
+      DO i=1, klon
+      IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k)
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) THEN
+            kcbot(i) = k
+            LDCUM(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+C
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: ajustement entre T et Q
+c======================================================================
+c Arguments:
+c pp---input-R- pression (Pa)
+c pt---input/output-R- temperature (K)
+c pq---input/output-R- vapeur d'eau (kg/kg)
+c======================================================================
+C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+C
+C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+C        KCALL=0    ENV. T AND QS IN*CUINI*
+C        KCALL=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL  ldflag(klon)
+      INTEGER KCALL
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zcond(klon), zcond1
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+C
+      DO 210 i=1, klon
+      IF (LDFLAG(i)) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond(i)=(pq(i)-zqsat) / (1. + zdqsat)
+         IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.)
+         IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.)
+         pt(i)=pt(i)+zldcp*zcond(i)
+         pq(i)=pq(i)-zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i=1, klon
+         if (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF(is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond1=(pq(i)-zqsat) / (1.+zdqsat)
+         pt(i)=pt(i)+zldcp*zcond1
+         pq(i)=pq(i)-zcond1
+      END IF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE fiajh(dtime, paprs, pplay, t, q,
+     .                 d_t, d_q, d_ql, rneb,
+     .                 rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT NONE
+c
+c Ajustement humide (Schema de convection de Manabe)
+C.
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime        ! intervalle du temps (s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL d_q(klon,klev) ! incrementation pour vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+c
+      REAL rain(klon)    ! variable non utilisee
+      REAL snow(klon)    ! variable non utilisee
+      INTEGER ibas(klon) ! variable non utilisee
+      INTEGER itop(klon) ! variable non utilisee
+
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+c
+c Variables locales:
+c 
+      INTEGER i, k
+      INTEGER k1, k1p, k2, k2p
+      LOGICAL itest(klon)
+      REAL delta_q(klon, klev)
+      REAL cp_new_t(klev)
+      REAL cp_delta_t(klev)
+      REAL new_qb(klev)
+      REAL v_cptj(klev), v_cptjk1, v_ssig
+      REAL v_cptt(klon,klev), v_p, v_t
+      REAL v_qs(klon,klev), v_qsd(klon,klev)
+      REAL zq1(klon), zq2(klon)
+      REAL gamcpdz(klon,2:klev)
+      REAL zdp, zdpm
+c
+      REAL zsat ! sur-saturation
+      REAL zflo ! flotabilite
+c
+      REAL local_q(klon,klev),local_t(klon,klev)
+c
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         local_q(i,k) = q(i,k)
+         local_t(i,k) = t(i,k)
+         rneb(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer v_qs et v_qsd:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer Gamma * Cp * dz: (gamm est le gradient critique)
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zdpm = paprs(i,k-1)-paprs(i,k)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * 
+     .                      (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) * 
+     .                      (v_qs(i,k-1)*zdpm + v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+
+     .                        v_qsd(i,k)*zdp)/(zdpm+zdp) )
+      ENDDO
+      ENDDO
+C
+C------------------------------------ modification des profils instables
+      DO 9999 i = 1, klon
+      itest(i) = .FALSE.
+C
+      k1 = 0
+      k2 = 1
+C
+  810 CONTINUE ! chercher k1, le bas de la colonne
+      k2 = k2 + 1
+      IF (k2 .GT. klev) GOTO 9999
+      zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2)
+      zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2))
+     .    +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
+      IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810
+      k1 = k2 - 1
+      itest(i) = .TRUE.
+C
+  820 CONTINUE ! chercher k2, le haut de la colonne
+      IF (k2 .EQ. klev) GOTO 821
+      k2p = k2 + 1
+      zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1))
+     .          *(local_q(i,k2p)-v_qs(i,k2p))
+      zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p)
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821
+      k2 = k2p
+      GOTO 820
+  821 CONTINUE
+C
+C------------------------------------------------------ ajustement local
+  830 CONTINUE ! ajustement proprement dit
+      v_cptj(k1) = 0.0
+      zdp = paprs(i,k1)-paprs(i,k1+1)
+      v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))
+     .               + RLVTT*(local_q(i,k1)-v_qs(i,k1)) ) * zdp
+      v_ssig = zdp * (1.0+v_qsd(i,k1))
+C
+      k1p = k1 + 1
+      DO k = k1p, k2
+         zdp = paprs(i,k)-paprs(i,k+1)
+         v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k)
+         v_cptjk1 = v_cptjk1 + zdp
+     .             * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k))
+     .               + RLVTT*(local_q(i,k)-v_qs(i,k)) )
+         v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k))
+      ENDDO
+C
+      DO k = k1, k2
+         cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
+         cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k)
+         new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT
+         local_q(i,k) = new_qb(k)
+         local_t(i,k) = cp_new_t(k) / RCPD
+      ENDDO
+C
+C--------------------------------------------------- sondage vers le bas
+C              -- on redefinit les variables prognostiques dans
+C              -- la colonne qui vient d'etre ajustee
+C
+      DO k = k1, k2
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+C
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      DO k = 2, klev
+         zdpm = paprs(i,k-1) - paprs(i,k)
+         zdp = paprs(i,k) - paprs(i,k+1)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) *
+     .                      (v_cptt(i,k-1)*zdpm+v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) *
+     .                      (v_qs(i,k-1)*zdpm+v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+v_qsd(i,k)*zdp)
+     .                      /(zdpm+zdp) )
+      ENDDO
+C
+C Verifier si l'on peut etendre la colonne vers le bas
+C
+      IF (k1 .EQ. 1) GOTO 841 ! extension echouee
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
+     .   + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee
+C
+  840 CONTINUE
+      k1 = k1 - 1
+      IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))
+     .             *(paprs(i,k1-1)-paprs(i,k1))
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN
+         GOTO 840
+      ELSE
+         GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      ENDIF
+  841 CONTINUE
+C
+      GOTO 810 ! chercher d'autres blocks en haut
+C
+ 9999 CONTINUE ! boucle sur tous les points
+C-----------------------------------------------------------------------
+c
+c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
+c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         delta_q(i,k) = local_q(i,k) - q(i,k)
+         IF (delta_q(i,k).LT.0.) rneb(i,k)  = 1.0
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
+c l'eau liquide est distribuee aux endroits ou la vapeur d'eau
+c diminue et d'une maniere proportionnelle a cet diminution):
+c
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zq1(i) = zq1(i) - delta_q(i,k) * zdp
+         zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp
+         ENDIF
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         IF (zq2(i).NE.0.0)
+     .      d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i)
+         ENDIF
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+          local_q(i, k) = MAX(local_q(i, k), seuil_vap)
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = local_t(i,k) - t(i,k)
+         d_q(i,k) = local_q(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE fiajc(dtime,paprs,pplay,
+     .                 t, q,conv_q,
+     .                 d_t, d_q, d_ql,rneb,
+     .                 rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT NONE
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Options:
+c
+      INTEGER plb ! niveau de depart pour la convection
+      PARAMETER (plb=4)
+c
+c Mystere: cette option n'est pas innocente pour les resultats !
+c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
+      LOGICAL vector ! calcul vectorise
+      PARAMETER (vector=.FALSE.)
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Arguments:
+c
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL t(klon,klev) ! temperature (K)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+      REAL dtime ! intervalle du temps (s)
+      REAL conv_q(klon,klev) ! taux de convergence de l'humidite
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL rain(klon) ! variable non-utilisee
+      REAL snow(klon) ! variable non-utilisee
+      INTEGER itop(klon) ! variable non-utilisee
+      INTEGER ibas(klon) ! variable non-utilisee
+c
+      INTEGER kh(klon), i, k
+      LOGICAL nuage(klon), test(klon,klev)
+      REAL zconv(klon), zdeh(klon,klev), zvirt(klon)
+      REAL zdqs(klon,klev), zqs(klon,klev)
+      REAL ztt, zvar, zfrac(klon)
+      REAL zq1(klon), zq2(klon)
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+          rneb(i,k) = 0.0
+          d_ql(i,k) = 0.0
+          d_t(i,k) = 0.0
+          d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         itop(i) = 0
+         ibas(i) = 0
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Calculer Qs et L/Cp * dQs/dT:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztt = t(i,k)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-ztt))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (ztt .LT. t_coup) THEN
+              zqs(i,k) = qsats(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsats(ztt,zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsatl(ztt,zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Determiner la difference de l'energie totale saturee:
+c
+      DO i = 1, klon
+         k = plb
+         zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie
+      ENDDO
+      DO k = plb+1, klev
+      DO i = 1, klon
+      zdeh(i,k) = zdeh(i,k-1)
+     .             + RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+      ENDDO
+      ENDDO
+c
+c Determiner le sommet du nuage selon l'instabilite
+c Calculer les convergences d'humidite (reelle et virtuelle)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i)  = k
+            zconv(i) = zconv(i)+conv_q(i,k)*dtime
+     .                         *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      IF (vector) THEN
+c
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+         test(i,k) = .TRUE.
+         zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+      ELSE
+         test(i,k) = .FALSE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+         zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+         zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                   * (paprs(i,k)-paprs(i,k+1))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      ELSE ! (.NOT. vector)
+c
+      DO 999 i = 1, klon
+      IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+ccc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
+ccc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
+         zfrac(i)  = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+         DO k = plb, kh(i)
+            zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+            d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .               - conv_q(i,k)*dtime
+            d_t(i,k) = zvar * zfrac(i) / RCPD
+         ENDDO
+c
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         DO k = plb, kh(i)
+            IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+            zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+            zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                      * (paprs(i,k)-paprs(i,k+1))
+         ENDDO
+         DO k = plb, kh(i)
+            IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+         ENDDO
+      ENDIF
+  999 CONTINUE
+c
+      ENDIF ! fin de teste sur vector
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect1.F	(revision 984)
@@ -0,0 +1,649 @@
+!
+! $Header$
+!
+      subroutine convect1(len,nd,ndp1,noff,minorig,
+     &                   t,q,qs,u,v,
+     &                   p,ph,iflag,ft,
+     &                   fq,fu,fv,precip,cbmf,delt,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect1.f	1.1 04/21/00
+C                       19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect1
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect1(len,nd,noff,minorig,
+C    &                   t,q,qs,u,v,
+C    &                   p,ph,iflag,ft,
+C    &                   fq,fu,fv,precip,cbmf,delt)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      noff          Integer        Input        integer limit for convection (nd-noff)
+C      minorig       Integer        Input        First level of convection
+C      t             Real           Input        temperature
+C      q             Real           Input        specific hum
+C      qs            Real           Input        sat specific hum
+C      u             Real           Input        u-wind
+C      v             Real           Input        v-wind
+C      p             Real           Input        full level pressure
+C      ph            Real           Input        half level pressure
+C      iflag         Integer        Output       iflag on latitude strip
+C      ft            Real           Output       temp tend
+C      fq            Real           Output       spec hum tend
+C      fu            Real           Output       u-wind tend
+C      fv            Real           Output       v-wind tend
+C      cbmf          Real           In/Out       cumulus mass flux
+C      delt          Real           Input        time step
+C      iflag         Integer        Output       integer flag for Emanuel conditions
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         convect2        Emanuel cumulus convection tendency calculations
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+       USE dimphy
+      implicit none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      real t(len,nd)
+      real q(len,nd)
+      real qs(len,nd)
+      real u(len,nd)
+      real v(len,nd)
+      real p(len,nd)
+      real ph(len,ndp1)
+      integer iflag(len)
+      real ft(len,nd)
+      real fq(len,nd)
+      real fu(len,nd)
+      real fv(len,nd)
+      real precip(len)
+      real cbmf(len)
+      real Ma(len,nd)
+      integer minorig
+      real delt,cpd,cpv,cl,rv,rd,lv0,g
+      real sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp
+      real alpha,entp,coeffs,coeffr,omtrain,cu
+c
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+      integer nl
+      integer nlp
+      integer nlm
+      integer i,k,n
+      real delti
+      real rowl
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real ginv
+      real hrd
+      real prccon1
+      integer icbmax
+      real lv(klon,klev)
+      real cpn(klon,klev)
+      real cpx(klon,klev)
+      real tv(klon,klev)
+      real gz(klon,klev)
+      real hm(klon,klev)
+      real h(klon,klev)
+      real work(klon)
+      integer ihmin(klon)
+      integer nk(klon)
+      real rh(klon)
+      real chi(klon)
+      real plcl(klon)
+      integer icb(klon)
+      real tnk(klon)
+      real qnk(klon)
+      real gznk(klon)
+      real pnk(klon)
+      real qsnk(klon)
+      real ticb(klon)
+      real gzicb(klon)
+      real tp(klon,klev)
+      real tvp(klon,klev)
+      real clw(klon,klev)
+c
+      real ah0(klon),cpp(klon)
+      real tg,qg,s,alv,tc,ahg,denom,es,rg
+c
+      integer ncum
+      integer idcum(klon)
+c
+      cpd=1005.7
+      cpv=1870.0
+      cl=4190.0
+      rv=461.5
+      rd=287.04
+      lv0=2.501E6
+      g=9.8
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+      sigs=0.12
+      sigd=0.05
+      elcrit=0.0011
+      tlcrit=-55.0
+      omtsnow=5.5
+      dtmax=0.9
+      damp=0.1
+      alpha=0.2
+      entp=1.5
+      coeffs=0.8
+      coeffr=1.0
+      omtrain=50.0
+c
+      cu=0.70
+      damp=0.1
+c
+c
+c Define nl, nlp, nlm, and delti
+c
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+      delti=1.0/delt
+!
+!-------------------------------------------------------------------
+! --- SET CONSTANTS
+!-------------------------------------------------------------------
+!
+      rowl=1000.0
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+      ginv=1.0/g
+      hrd=0.5*rd
+      prccon1=86400.0*1000.0/(rowl*g)
+!
+! dtmax is the maximum negative temperature perturbation.
+!
+!=====================================================================
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!=====================================================================
+!
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft(i,k)=0.0
+         fq(i,k)=0.0
+         fu(i,k)=0.0
+         fv(i,k)=0.0
+         tvp(i,k)=0.0
+         tp(i,k)=0.0
+         clw(i,k)=0.0
+         gz(i,k) = 0.
+ 10     continue
+ 20   continue
+      do 60 i=1,len
+        precip(i)=0.0
+        iflag(i)=0
+ 60   continue
+c
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+      do 110 k=1,nl+1
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+c
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+!
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+!
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+c
+      ncum=0
+      do 400 i=1,len
+        if(iflag(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+c
+c Call convect2, which compresses the points and computes the heating,
+c moistening, velocity mixing, and precipiation.
+c
+c     print*,'cpd avant convect2 ',cpd
+      if(ncum.gt.0)then
+      call convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &              nk,icb,
+     &              t,q,qs,u,v,gz,tv,tp,tvp,clw,h,
+     &              lv,cpn,p,ph,ft,fq,fu,fv,
+     &              tnk,qnk,gznk,plcl,
+     &              precip,cbmf,iflag,
+     &              delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &              sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &              alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+      endif
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect2.F	(revision 984)
@@ -0,0 +1,1395 @@
+!
+! $Header$
+!
+      subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &                 nk1,icb1,
+     &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+     &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+     &                 tnk1,qnk1,gznk1,plcl1,
+     &                 precip1,cbmf1,iflag1,
+     &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &                 alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect2.f	1.2 05/18/00
+C                       22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect2
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme - compute tendencies
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect2(ncum,idcum,len,nd,nl,minorig,
+C    &                 nk1,icb1,
+C    &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+C    &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+C    &                 tnk1,qnk1,gznk1,plcl1,
+C    &                 precip1,cbmf1,iflag1,
+C    &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+C    &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+C    &                 alpha,entp,coeffs,coeffr,omtrain,cu)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      ncum          Integer        Input        number of cumulus points
+C      idcum         Integer        Input        index of cumulus point
+C      len           Integer        Input        first dimension
+C      nd            Integer        Input        total vertical dimension
+C      ndp1          Integer        Input        nd + 1
+C      nl            Integer        Input        vertical dimension for convection
+C      minorig       Integer        Input        First level where convection is allow to begin
+C      nk1           Integer        Input        First level of convection
+C      ncb1          Integer        Input        Level of free convection
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      gz1           Real           Inout        geop
+C      tv1           Real           Input        virtual temp
+C      tp1           Real           Input
+C      clw1          Real           Inout        cloud liquid water
+C      h1            Real           Inout
+C      lv1           Real           Inout
+C      cpn1          Real           Inout
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      precip1       Real           Output       prec
+C      cbmf1         Real           In/Out       cumulus mass flux
+C      iflag1        Integer        Output       iflag on latitude strip
+C      delt          Real           Input        time step
+C      cpd           Integer        Input        See description below
+C      cpv           Integer        Input        See description below
+C      cl            Integer        Input        See description below
+C      rv            Integer        Input        See description below
+C      rd            Integer        Input        See description below
+C      lv0           Integer        Input        See description below
+C      g             Integer        Input        See description below
+C      sigs          Integer        Input        See description below
+C      sigd          Integer        Input        See description below
+C      elcrit        Integer        Input        See description below
+C      tlcrit        Integer        Input        See description below
+C      omtsnow       Integer        Input        See description below
+C      dtmax         Integer        Input        See description below
+C      damp          Integer        Input        See description below
+C      alpha         Integer        Input        See description below
+C      ent           Integer        Input        See description below
+C      coeffs        Integer        Input        See description below
+C      coeffr        Integer        Input        See description below
+C      omtrain       Integer        Input        See description below
+C      cu            Integer        Input        See description below
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         zilch        Zero out an array
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+      USE dimphy
+      implicit none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer kmax2,imax2,kmin2,imin2
+      real ftmax2,ftmin2
+      integer kmax,imax,kmin,imin
+      real ftmax,ftmin
+c
+      integer ncum
+      integer idcum(len)
+      integer len
+      integer nd
+      integer ndp1
+      integer nl
+      integer minorig
+      integer nk1(len)
+      integer icb1(len)
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real gz1(len,nd)
+      real tv1(len,nd)
+      real tp1(len,nd)
+      real tvp1(len,nd)
+      real clw1(len,nd)
+      real h1(len,nd)
+      real lv1(len,nd)
+      real cpn1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real tnk1(len)
+      real qnk1(len)
+      real gznk1(len)
+      real precip1(len)
+      real cbmf1(len)
+      real plcl1(len)
+      integer iflag1(len)
+      real delt
+      real cpd
+      real cpv
+      real cl
+      real rv
+      real rd
+      real lv0
+      real g
+      real sigs    ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE
+      real sigd    ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT
+      real elcrit  ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm)
+      real tlcrit  ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-
+c                     CONVERSION THRESHOLD IS ASSUMED TO BE ZERO
+      real omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW
+      real dtmax   ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
+c                    A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC.
+      real damp
+      real alpha
+      real entp    ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION
+      real coeffs  ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF SNOW
+      real coeffr  ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF RAIN
+      real omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN
+      real cu      ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT
+c
+      real Ma(len,nd)
+c
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+c Local arrays.
+c
+      real work(ncum)
+      real t(ncum,klev)
+      real q(ncum,klev)
+      real qs(ncum,klev)
+      real u(ncum,klev)
+      real v(ncum,klev)
+      real gz(ncum,klev)
+      real h(ncum,klev)
+      real lv(ncum,klev)
+      real cpn(ncum,klev)
+      real p(ncum,klev)
+      real ph(ncum,klev)
+      real ft(ncum,klev)
+      real fq(ncum,klev)
+      real fu(ncum,klev)
+      real fv(ncum,klev)
+      real precip(ncum)
+      real cbmf(ncum)
+      real plcl(ncum)
+      real tnk(ncum)
+      real qnk(ncum)
+      real gznk(ncum)
+      real tv(ncum,klev)
+      real tp(ncum,klev)
+      real tvp(ncum,klev)
+      real clw(ncum,klev)
+c     real det(ncum,klev)
+      real dph(ncum,klev)
+c     real wd(ncum)
+c     real tprime(ncum)
+c     real qprime(ncum)
+      real ah0(ncum)
+      real ep(ncum,klev)
+      real sigp(ncum,klev)
+      integer nent(ncum,klev)
+      real water(ncum,klev)
+      real evap(ncum,klev)
+      real mp(ncum,klev)
+      real m(ncum,klev)
+      real qti
+      real wt(ncum,klev)
+      real hp(ncum,klev)
+      real lvcp(ncum,klev)
+      real elij(ncum,klev,klev)
+      real ment(ncum,klev,klev)
+      real sij(ncum,klev,klev)
+      real qent(ncum,klev,klev)
+      real uent(ncum,klev,klev)
+      real vent(ncum,klev,klev)
+      real qp(ncum,klev)
+      real up(ncum,klev)
+      real vp(ncum,klev)
+      real cape(ncum)
+      real capem(ncum)
+      real frac(ncum)
+      real dtpbl(ncum)
+      real tvpplcl(ncum)
+      real tvaplcl(ncum)
+      real dtmin(ncum)
+      real w3d(ncum,klev)
+      real am(ncum)
+      real ents(ncum)
+      real uav(ncum)
+      real vav(ncum)
+c
+      integer iflag(ncum)
+      integer nk(ncum)
+      integer icb(ncum)
+      integer inb(ncum)
+      integer inb1(ncum)
+      integer jtt(ncum)
+c
+      integer nn,i,k,n,icbmax,nlp,j
+      integer ij
+      integer nn2,nn3
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real tg,qg,s,alv,tc,ahg,denom,es,rg,ginv,rowl
+      real delti
+      real tca,elacrit
+      real by,defrac
+c     real byp
+      real byp(ncum)
+      logical lcape(ncum)
+      real dbo
+      real bf2,anum,dei,altem,cwat,stemp
+      real alt,qp1,smid,sjmax,sjmin
+      real delp,delm
+      real awat,coeff,afac,revap,dhdp,fac,qstm,rat
+      real qsm,sigt,b6,c6
+      real dpinv,cpinv
+      real fqold,ftold,fuold,fvold
+      real wdtrain(ncum),xxx
+      real bsum(ncum,klev)
+      real asij(ncum)
+      real smin(ncum)
+      real scrit(ncum)
+c     real amp1,ad
+      real amp1(ncum),ad(ncum)
+      logical lwork(ncum)
+      integer num1,num2
+c
+c     print*,'cpd en entree de convect2 ',cpd
+      nlp=nl+1
+c
+      rowl=1000.0
+      ginv=1.0/g
+      delti=1.0/delt
+c
+c Define some thermodynamic variables.
+c
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c
+c Compress the fields.
+c
+      do 110 k=1,nl+1
+       nn=0
+	do 100 i=1,len
+	  if(iflag1(i).eq.0)then
+	    nn=nn+1
+	    t(nn,k)=t1(i,k)
+	    q(nn,k)=q1(i,k)
+	    qs(nn,k)=qs1(i,k)
+	    u(nn,k)=u1(i,k)
+	    v(nn,k)=v1(i,k)
+	    gz(nn,k)=gz1(i,k)
+	    h(nn,k)=h1(i,k)
+	    lv(nn,k)=lv1(i,k)
+	    cpn(nn,k)=cpn1(i,k)
+	    p(nn,k)=p1(i,k)
+	    ph(nn,k)=ph1(i,k)
+	    tv(nn,k)=tv1(i,k)
+	    tp(nn,k)=tp1(i,k)
+	    tvp(nn,k)=tvp1(i,k)
+	    clw(nn,k)=clw1(i,k)
+	  endif
+ 100    continue
+c       print*,'100 ncum,nn',ncum,nn
+ 110  continue
+      nn=0
+      do 150 i=1,len
+	if(iflag1(i).eq.0)then
+	  nn=nn+1
+	  cbmf(nn)=cbmf1(i)
+	  plcl(nn)=plcl1(i)
+	  tnk(nn)=tnk1(i)
+	  qnk(nn)=qnk1(i)
+	  gznk(nn)=gznk1(i)
+	  nk(nn)=nk1(i)
+	  icb(nn)=icb1(i)
+	  iflag(nn)=iflag1(i)
+	endif
+ 150  continue
+c       print*,'150 ncum,nn',ncum,nn
+c
+c Initialize the tendencies, det, wd, tprime, qprime.
+c
+      do 170 k=1,nl
+	do 160 i=1,ncum
+c         det(i,k)=0.0
+	  ft(i,k)=0.0
+	  fu(i,k)=0.0
+	  fv(i,k)=0.0
+	  fq(i,k)=0.0
+	  dph(i,k)=ph(i,k)-ph(i,k+1)
+	  ep(i,k)=0.0
+	  sigp(i,k)=sigs
+ 160    continue
+ 170  continue
+      do 180 i=1,ncum
+c      wd(i)=0.0
+c      tprime(i)=0.0
+c      qprime(i)=0.0
+       precip(i)=0.0
+       ft(i,nl+1)=0.0
+       fu(i,nl+1)=0.0
+       fv(i,nl+1)=0.0
+       fq(i,nl+1)=0.0
+ 180  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 230 i=1,ncum
+	icbmax=max(icbmax,icb(i))
+ 230  continue
+c
+c
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+	ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+	       tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)
+     &                  /cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-273.15
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c
+c=====================================================================
+c --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          water(i,1)=0.0
+          evap(i,1)=0.0
+          mp(i,1)=0.0
+          m(i,1)=0.0
+          wt(i,1)=omtsnow
+          hp(i,1)=h(i,1)
+c         if(.not.cpn(i,1).gt.900.) then
+c         print*,'i,lv(i,1),cpn(i,1)'
+c         print*, i,lv(i,1),cpn(i,1)
+c         k=(i-1)/ncum+1
+c         print*,'i,k',mod(i,ncum),k,'  cpn',cpn(mod(i,ncum),k)
+c         stop
+c         endif
+          lvcp(i,1)=lv(i,1)/cpn(i,1)
+ 360    continue
+c
+      do 380 i=1,ncum*nlp*nlp
+        elij(i,1,1)=0.0
+        ment(i,1,1)=0.0
+        sij(i,1,1)=0.0
+ 380  continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+ 385      continue
+ 390    continue
+ 400  continue
+c
+      do 420 i=1,ncum
+        qp(i,1)=q(i,1)
+        up(i,1)=u(i,1)
+        vp(i,1)=v(i,1)
+ 420  continue
+      do 440 k=2,nlp
+        do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430    continue
+ 440  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),
+c --- AT EACH MODEL LEVEL
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+c
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+c     wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
+c     qprime=0.5*(qp(1)-q(1))
+c     tprime=lv0*qprime/cpd
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+           endif
+ 1910    continue
+ 1920   continue
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+ 2010     continue
+ 2020   continue
+c
+      DO k=1,nd
+        DO i=1,len
+         Ma(i,k) = 0.
+        ENDDO
+      ENDDO
+      DO k=nl,1,-1
+        DO i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        ENDDO
+      ENDDO
+c
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect3.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect3.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/convect3.F	(revision 984)
@@ -0,0 +1,1408 @@
+!
+! $Header$
+!
+      SUBROUTINE CONVECT3	
+     *    (DTIME,EPMAX,ok_adj,
+     *     T1,   R1,   RS,    U,  V,  TRA,   P,     PH,
+     *     ND,       NDP1,     NL, NTRA,  DELT,  IFLAG,
+     *     FT, FR, FU,  FV,  FTRA,  PRECIP,
+     *     icb,inb,   upwd,dnwd,dnwd0,SIG, W0,Mike,Mke,
+     *     Ma,MENTS,QENTS,TPS,TLS,SIGIJ,CAPE,TVP,PBASE,BUOYBASE,
+cccc     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
+     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR,   ! sbl
+     *     FT2,FR2,FU2,FV2,WD,QCOND,QCONDC)   ! sbl
+C
+C    ***  THE PARAMETER NA SHOULD IN GENERAL EQUAL ND   ***
+C
+c#################################################################
+cFleur       Introduction des traceurs dans convect3 le 6 juin 200
+c#################################################################
+      USE dimphy
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+      PARAMETER (NA=60)
+
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+      REAL DELTAC              ! cld
+      PARAMETER (DELTAC=0.01)  ! cld
+
+      INTEGER NENT(NA)
+      REAL T1(ND),R1(ND),RS(ND),U(ND),V(ND),TRA(ND,NTRA)
+      REAL P(ND),PH(NDP1)
+      REAL FT(ND),FR(ND),FU(ND),FV(ND),FTRA(ND,NTRA)
+      REAL SIG(ND),W0(ND)
+      REAL UENT(NA,NA),VENT(NA,NA),TRAENT(NA,NA,NTRAC),TRATM(NA)
+      REAL UP(NA),VP(NA),TRAP(NA,NTRAC)
+      REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
+      REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
+      REAL RP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
+      REAL SIGP(NA),B(NA),TP(NA),CPN(NA)
+      REAL LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA)
+      REAL T(NA),RR(NA)
+C
+      REAL FT2(ND),FR2(ND),FU2(ND),FV2(ND) ! added sbl
+      REAL U1(ND),V1(ND) ! added sbl
+C
+      REAL BUOY(NA)     !  Lifted parcel buoyancy
+      REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                      temperature wrt T1 and Q1
+      REAL CLW_NEW(NA),QI(NA)
+C
+      REAL WD, BETAD ! for gust factor (sb)
+      REAL QCONDC(ND)  ! interface cld param (sb)
+      REAL QCOND(ND),NQCOND(NA),WA(NA),MAA(NA),SIGA(NA),AXC(NA) ! cld
+C
+      LOGICAL ICE_CONV,ok_adj
+      PARAMETER (ICE_CONV=.TRUE.)
+ 
+cccccccccccccccccccccccccccccccccccccccccccccc
+c     declaration des variables a sortir
+ccccccccccccccccccccccccccccccccccccccccccccc
+      real Mke(nd)
+      real Mike(nd)
+      real Ma(nd)
+      real TPS(ND) !temperature dans les ascendances non diluees
+      real TLS(ND) !temperature potentielle
+      real MENTS(nd,nd)
+      real QENTS(nd,nd)
+      REAL SIGIJ(KLEV,KLEV)
+      REAL PBASE ! pressure at the cloud base level
+      REAL BUOYBASE ! buoyancy at the cloud base level
+cccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+ 
+c
+      real dnwd0(nd)  !  precipitation driven unsaturated downdraft flux
+      real dnwd(nd), dn1  ! in-cloud saturated downdraft mass flux
+      real upwd(nd), up1  ! in-cloud saturated updraft mass flux
+C
+C   ***         ASSIGN VALUES OF THERMODYNAMIC CONSTANTS        ***
+C   ***             THESE SHOULD BE CONSISTENT WITH             ***
+C   ***              THOSE USED IN CALLING PROGRAM              ***
+C   ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
+C
+c sb      CPD=1005.7
+c sb      CPV=1870.0
+c sb      CL=4190.0
+c sb      CPVMCL=CL-CPV
+c sb      RV=461.5
+c sb      RD=287.04
+c sb      EPS=RD/RV
+c sb      ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CPVMCL=CL-CPV
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+cccccccccccccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+       NK = 1 ! origin level of the lifted parcel
+c
+cccccccccccccccccccccc
+C
+C           ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
+C
+      DO 5 I=1,ND
+         FT(I)=0.0
+         FR(I)=0.0
+         FU(I)=0.0
+         FV(I)=0.0
+
+         FT2(I)=0.0
+         FR2(I)=0.0
+         FU2(I)=0.0
+         FV2(I)=0.0
+
+         DO 4 J=1,NTRA
+          FTRA(I,J)=0.0
+    4    CONTINUE
+
+         QCONDC(I)=0.0  ! cld
+         QCOND(I)=0.0   ! cld
+         NQCOND(I)=0.0  ! cld
+
+         T(I)=T1(I)
+         RR(I)=R1(I)
+         U1(I)=U(I) ! added sbl
+         V1(I)=V(I) ! added sbl
+    5 CONTINUE
+      DO 7 I=1,NL
+         RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+         TH(I)=T(I)*(1000.0/P(I))**RDCP
+    7 CONTINUE
+C
+*************************************************************
+**    CALCUL DES TEMPERATURES POTENTIELLES A SORTIR
+*************************************************************
+      do i=1,ND
+      RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+ 
+      TLS(i)=T(I)*(1000.0/P(I))**RDCP
+      enddo
+ 
+ 
+ 
+ 
+************************************************************
+ 
+ 
+      PRECIP=0.0
+      WD=0.0 ! sb
+      IFLAG=1
+C
+C   ***                    SPECIFY PARAMETERS                        ***
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE   ***
+C   ***       PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO         ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP.      ***
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY                 ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE      ***
+C   ***                        OF CLOUD                              ***
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY)    ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)             ***
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***                     IT MUST BE LESS THAN 0                   ***
+C
+      PBCRIT=150.0
+      PTCRIT=500.0
+      SIGD=0.01
+      SPFAC=0.15
+c sb:
+c     EPMAX=0.993 ! precip efficiency less than unity
+c      EPMAX=1. ! precip efficiency less than unity
+C
+Cjyg
+CCC      BETA=0.96
+C  Beta is now expressed as a function of the characteristic time
+C  of the convective process.
+CCC        Old value : TAU = 15000.   !(for dtime = 600.s)
+CCC        Other value (inducing little change) :TAU = 8000.
+      TAU = 8000.
+      BETA = 1.-DTIME/TAU
+Cjyg
+CCC      ALPHA=1.0
+      ALPHA=1.5E-3*DTIME/TAU
+C        Increase alpha in order to compensate W decrease
+      ALPHA = ALPHA*1.5
+C
+Cjyg (voir CONVECT 3)
+CCC      DTCRIT=-0.2
+      DTCRIT=-2.
+Cgf&jyg
+CCC     DT pour l'overshoot.
+      DTOVSH = -0.2
+ 
+C
+C           ***        INCREMENT THE COUNTER       ***
+C
+      SIG(ND)=SIG(ND)+1.0
+      SIG(ND)=AMIN1(SIG(ND),12.1)
+C
+C           ***    IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT     ***
+C           ***     RETURNS ARRAYS T AND R THAT MAY HAVE BEEN      ***
+C           ***  ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE    ***
+C           ***        THE RETURNED ARRAYS ARE UNALTERED.          ***
+C
+      NOPT=0
+c!      NOPT=1 ! sbl
+C
+C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
+C
+C     ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
+C     ***                BOUNDARY LAYER SCHEME !!!               ***
+C
+      IF (ok_adj) THEN ! added sbl
+
+      DO 30 I=NL-1,1,-1
+         JN=0
+         DO 10 J=I+1,NL
+   10    IF(TH(J).LT.TH(I))JN=J
+         IF(JN.EQ.0)GOTO 30
+         AHM=0.0
+         RM=0.0
+         UM=0.0
+         VM=0.0
+         DO K=1,NTRA
+          TRATM(K)=0.0
+         END DO
+         DO 15 J=I,JN
+          AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1))
+          RM=RM+RR(J)*(PH(J)-PH(J+1))
+          UM=UM+U(J)*(PH(J)-PH(J+1))
+          VM=VM+V(J)*(PH(J)-PH(J+1))
+          DO K=1,NTRA
+           TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1))
+          END DO
+   15    CONTINUE
+         DPHINV=1./(PH(I)-PH(JN+1))
+         RM=RM*DPHINV
+         UM=UM*DPHINV
+         VM=VM*DPHINV
+         DO K=1,NTRA
+          TRATM(K)=TRATM(K)*DPHINV
+         END DO
+         A2=0.0
+         DO 20 J=I,JN
+            RR(J)=RM
+          U(J)=UM
+          V(J)=VM
+          DO K=1,NTRA
+           TRA(J,K)=TRATM(K)
+          END DO
+            RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV)
+            X=(0.001*P(J))**RDCP
+            T(J)=X
+            A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1))
+   20    CONTINUE
+         DO 25 J=I,JN
+            TH(J)=AHM/A2
+            T(J)=T(J)*TH(J)
+   25    CONTINUE
+   30 CONTINUE
+
+      ENDIF ! added sbl
+C
+C   ***   RESET INPUT ARRAYS IF ok_adj 0   ***
+C
+      IF (ok_adj)THEN
+         DO 35 I=1,ND
+
+           FT2(I)=(T(I)-T1(I))/DELT  ! sbl
+           FR2(I)=(RR(I)-R1(I))/DELT  ! sbl
+           FU2(I)=(U(I)-U1(I))/DELT  ! sbl
+           FV2(I)=(V(I)-V1(I))/DELT  ! sbl
+
+c!            T1(I)=T(I)      ! commente sbl
+c!            R1(I)=RR(I)     ! commente sbl
+   35    CONTINUE
+      END IF
+C
+C  *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+C
+      GZ(1)=0.0
+      CPN(1)=CPD*(1.-RR(1))+RR(1)*CPV
+      H(1)=T(1)*CPN(1)
+      DO 40 I=2,NL
+        TVX=T(I)*(1.+RR(I)/EPS-RR(I))
+        TVY=T(I-1)*(1.+RR(I-1)/EPS-RR(I-1))
+        GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I)
+        CPN(I)=CPD*(1.-RR(I))+CPV*RR(I)
+        H(I)=T(I)*CPN(I)+GZ(I)
+   40 CONTINUE
+C
+C   ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL ***
+C   ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)     ***
+C
+      IF (T(1).LT.250.0.OR.RR(1).LE.0.0)THEN
+         IFLAG=0
+c sb3d         print*,'je suis passe par 366'
+         RETURN
+      END IF
+
+cjyg1 Utilisation de la subroutine CLIFT
+CC      RH=RR(1)/RS(1)
+CC      CHI=T(1)/(1669.0-122.0*RH-T(1))
+CC      PLCL=P(1)*(RH**CHI)
+      CALL CLIFT(P(1),T(1),RR(1),RS(1),PLCL,DPLCLDT,DPLCLDR)
+cjyg2
+c sb3d      PRINT *,' em_plcl,p1,t1,r1,rs1,rh '
+c sb3d     $        ,PLCL,P(1),T(1),RR(1),RS(1),RH
+c
+      IF (PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+         IFLAG=2
+         RETURN
+      END IF
+Cjyg1
+C     Essais de modification de ICB
+C
+C   ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
+C
+CC      ICB=NL-1
+CC      DO 50 I=2,NL-1
+CC         IF(P(I).LT.PLCL)THEN
+CC            ICB=MIN(ICB,I)   ! ICB sup ou egal a 2
+CC         END IF
+CC   50 CONTINUE
+CC      IF(ICB.EQ.(NL-1))THEN
+CC         IFLAG=3
+CC         RETURN
+CC      END IF
+C
+C   *** CALCULATE LAYER CONTAINING LCL (=ICB)   ***
+C
+      ICB=NL-1
+c sb      DO 50 I=2,NL-1
+      DO 50 I=3,NL-1 ! modif sb pour que ICB soit sup/egal a 2
+C   la modification consiste a comparer PLCL a PH et non a P:
+C   ICB est defini par :  PH(ICB)<PLCL<PH(ICB-!)
+         IF(PH(I).LT.PLCL)THEN
+            ICB=MIN(ICB,I)
+         END IF
+   50 CONTINUE
+      IF(ICB.EQ.(NL-1))THEN
+         IFLAG=3
+         RETURN
+      END IF
+      ICB = ICB-1 ! ICB sup ou egal a 2 
+Cjyg2
+C
+C
+ 
+C   *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL      ***
+C   ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC             ***
+C   ***                   LIQUID WATER CONTENT                             ***
+C
+ 
+cjyg1
+c make sure that "Cloud base" seen by TLIFT is actually the 
+c fisrt level where adiabatic ascent is saturated 
+       IF (PLCL .GT. P(ICB)) THEN
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ELSE
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ENDIF
+cjyg2
+ 
+******************************************************************************
+****     SORTIE DE LA TEMPERATURE DE L ASCENDANCE NON DILUE
+******************************************************************************
+        do i=1,ND
+        TPS(i)=TP(i)
+        enddo
+ 
+ 
+******************************************************************************
+ 
+C
+C   ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
+C   ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
+C   ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
+C
+      DO 55 I=1,NL
+         PDEN=PTCRIT-PBCRIT
+c
+cjyg
+ccc         EP(I)=(P(ICB)-P(I)-PBCRIT)/PDEN
+c sb         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN
+         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN * EPMAX ! sb
+c
+         EP(I)=AMAX1(EP(I),0.0)
+c sb         EP(I)=AMIN1(EP(I),1.0)
+         EP(I)=AMIN1(EP(I),EPMAX) ! sb
+         SIGP(I)=SPFAC
+C
+C   ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
+C   ***                    VIRTUAL TEMPERATURE                    ***
+C
+         TV(I)=T(I)*(1.+RR(I)/EPS-RR(I))
+Ccd1
+C    . Keep all liquid water in lifted parcel (-> adiabatic CAPE)
+C
+ccc    TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I))
+c!!! sb         TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift
+Ccd2
+C
+C   ***       Calculate first estimate of buoyancy
+C
+         BUOY(I) = TVP(I) - TV(I)
+   55 CONTINUE
+C
+C   ***   Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy
+C
+      DPBASE = -40.   !That is 400m above LCL
+      PBASE = PLCL + DPBASE
+      TVPBASE = TVP(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $         +TVP(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+      TVBASE = TV(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $        +TV(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+C
+c test sb:
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c@      write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1)
+c@     :             ,tv(icb),tv(icb1)'
+c@      write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb)
+c@     L          ,tvp(icb+1),tv(icb),tv(icb+1)
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c fin test sb
+      BUOYBASE = TVPBASE - TVBASE
+C
+CC       Set buoyancy = BUOYBASE for all levels below BASE.
+CC       For safety, set : BUOY(ICB) = BUOYBASE
+      DO I = ICB,NL
+        IF (P(I) .GE. PBASE) THEN
+          BUOY(I) = BUOYBASE
+        ENDIF
+      ENDDO
+      BUOY(ICB) = BUOYBASE
+C
+c sb3d      print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl'
+c sb3d     $,        buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl
+c sb3d      print *,'TVP ',(tvp(i),i=1,nl)
+c sb3d      print *,'TV ',(tv(i),i=1,nl)
+c sb3d      print *, 'P ',(p(i),i=1,nl)
+c sb3d      print *,'ICB ',icb
+c test sb:
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c@      write(*,*) 'icb,icbs,inb,buoybase:'
+c@      write(*,*) icb,icb+1,inb,buoybase
+c@      write(*,*) 'k,tvp,tv,tp,buoy,ep: '
+c@      do k=1,nl
+c@      write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k)
+c@      enddo
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c fin test sb
+
+
+C
+C   ***   MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE  ***
+C   ***    AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT  ***
+C   ***                         AT CLOUD BASE                         ***
+C   ***       IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING       ***
+C   ***                        SIG(I) AND W0(I)                       ***
+C
+Cjyg
+CCC      TDIF=TVP(ICB)-TV(ICB)
+      TDIF = BUOY(ICB)
+      ATH1=TH(1)
+Cjyg
+CCC      ATH=TH(ICB-1)-1.0
+      ATH=TH(ICB-1)-5.0
+c      ATH=0.                          ! ajout sb
+c      IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb
+      IF(TDIF.LT.DTCRIT.OR.ATH.GT.ATH1)THEN
+         DO 60 I=1,NL
+            SIG(I)=BETA*SIG(I)-2.*ALPHA*TDIF*TDIF
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   60    CONTINUE
+         IFLAG=0
+         RETURN
+      END IF
+C
+ 
+ 
+C   ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
+C   ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS       ***
+C
+      DO 70 I=1,NL
+         HP(I)=H(I)
+         WT(I)=0.001
+         RP(I)=RR(I)
+         UP(I)=U(I)
+         VP(I)=V(I)
+         DO 71 J=1,NTRA
+          TRAP(I,J)=TRA(I,J)
+   71    CONTINUE
+         NENT(I)=0
+         WATER(I)=0.0
+         EVAP(I)=0.0
+         B(I)=0.0
+         MP(I)=0.0
+         M(I)=0.0
+         LV(I)=ALV0-CPVMCL*(T(I)-273.15)
+         LVCP(I)=LV(I)/CPN(I)
+         DO 70 J=1,NL
+            QENT(I,J)=RR(J)
+            ELIJ(I,J)=0.0
+            MENT(I,J)=0.0
+            SIJ(I,J)=0.0
+          UENT(I,J)=U(J)
+          VENT(I,J)=V(J)
+          DO 70 K=1,NTRA
+           TRAENT(I,J,K)=TRA(J,K)
+   70 CONTINUE
+ 
+      DELTI=1.0/DELT
+C
+C  ***  FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S       ***
+C  ***                LEVEL OF NEUTRAL BUOYANCY                   ***
+C
+      INB=NL-1
+      DO 80 I=ICB,NL-1
+Cjyg
+CCC         IF((TVP(I)-TV(I)).LT.DTCRIT)THEN
+         IF(BUOY(I).LT.DTOVSH)THEN
+            INB=MIN(INB,I)
+         END IF
+   80 CONTINUE
+ 
+ 
+ 
+ 
+C
+C   ***          RESET SIG(I) AND W0(I) FOR I>INB AND I<ICB       ***
+C
+      IF(INB.LT.(NL-1))THEN
+         DO 85 I=INB+1,NL-1
+Cjyg
+CCC            SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(INB)-TVP(INB))*
+CCC     1              ABS(TV(INB)-TVP(INB))
+            SIG(I)=BETA*SIG(I)+2.*ALPHA*BUOY(INB)*
+     1              ABS(BUOY(INB))
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   85    CONTINUE
+      END IF
+      DO 87 I=1,ICB
+Cjyg
+CCC         SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(ICB)-TVP(ICB))*
+CCC     1           (TV(ICB)-TVP(ICB))
+         SIG(I)=BETA*SIG(I)-2.*ALPHA*BUOY(ICB)*BUOY(ICB)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         W0(I)=BETA*W0(I)
+   87 CONTINUE
+C
+C   ***    RESET FRACTIONAL AREAS OF UPDRAFTS AND W0 AT INITIAL TIME    ***
+C   ***           AND AFTER 10 TIME STEPS OF NO CONVECTION              ***
+C
+ 
+      IF(SIG(ND).LT.1.5.OR.SIG(ND).GT.12.0)THEN
+         DO 90 I=1,NL-1
+            SIG(I)=0.0
+            W0(I)=0.0
+   90    CONTINUE
+      END IF
+C
+C   ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
+C
+      DO 95 I=ICB,INB
+         HP(I)=H(1)+(LV(I)+(CPD-CPV)*T(I))*EP(I)*CLW(I)
+   95 CONTINUE
+C
+C   ***  CALCULATE CONVECTIVE AVAILABLE POTENTIAL ENERGY (CAPE),  ***
+C   ***     VERTICAL VELOCITY (W), FRACTIONAL AREA COVERED BY     ***
+C   ***     UNDILUTE UPDRAFT (SIG),  AND UPDRAFT MASS FLUX (M)    ***
+C
+      CAPE=0.0
+C
+      DO 98 I=ICB+1,INB
+Cjyg1
+CCC         CAPE=CAPE+RD*(TVP(I-1)-TV(I-1))*(PH(I-1)-PH(I))/P(I-1)
+CCC         DCAPE=RD*BUOY(I-1)*(PH(I-1)-PH(I))/P(I-1)
+CCC         DLNP=(PH(I-1)-PH(I))/P(I-1)
+C          The interval on which CAPE is computed starts at PBASE :
+         DELTAP = MIN(PBASE,PH(I-1))-MIN(PBASE,PH(I))
+         CAPE=CAPE+RD*BUOY(I-1)*DELTAP/P(I-1)
+         DCAPE=RD*BUOY(I-1)*DELTAP/P(I-1)
+         DLNP=DELTAP/P(I-1)
+Cjyg2
+c sb3d         print *,'buoy,dlnp,dcape,cape',buoy(i-1),dlnp,dcape,cape
+c test sb:
+c@       write(*,*) '############################################'
+c@         write(*,*) 'cape,rrd,buoy,deltap,p,pbase,ph:'
+c@     :     ,cape,rd,buoy(i-1),deltap,p(i-1),pbase,ph(i)
+c@       write(*,*) '############################################'
+
+c fin test sb
+         CAPE=AMAX1(0.0,CAPE)
+C
+         SIGOLD=SIG(I)
+         DTMIN=100.0
+         DO 97 J=ICB,I-1
+Cjyg
+CCC            DTMIN=AMIN1(DTMIN,(TVP(J)-TV(J)))
+            DTMIN=AMIN1(DTMIN,BUOY(J))
+   97    CONTINUE
+c sb3d     print *, 'DTMIN, BETA, ALPHA, SIG = ',DTMIN,BETA,ALPHA,SIG(I)
+         SIG(I)=BETA*SIG(I)+ALPHA*DTMIN*ABS(DTMIN)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         SIG(I)=AMIN1(SIG(I),0.01)
+         FAC=AMIN1(((DTCRIT-DTMIN)/DTCRIT),1.0)
+Cjyg
+CC    Essais de reduction de la vitesse
+CC         FAC = FAC*.5
+C
+         W=(1.-BETA)*FAC*SQRT(CAPE)+BETA*W0(I)
+         AMU=0.5*(SIG(I)+SIGOLD)*W
+         M(I)=AMU*0.007*P(I)*(PH(I)-PH(I+1))/TV(I)
+
+c --------- test sb:
+c       write(*,*) '############################################'
+c       write(*,*) 'k,amu,buoy(k-1),deltap,w,beta,fac,cape,w0(k)'
+c       write(*,*) i,amu,buoy(i-1),deltap
+c     :           ,w,beta,fac,cape,w0(i)
+c       write(*,*) '############################################'
+c ---------
+
+         W0(I)=W
+   98 CONTINUE
+      W0(ICB)=0.5*W0(ICB+1)
+      M(ICB)=0.5*M(ICB+1)*(PH(ICB)-PH(ICB+1))/(PH(ICB+1)-PH(ICB+2))
+      SIG(ICB)=SIG(ICB+1)
+      SIG(ICB-1)=SIG(ICB)
+cjyg1
+c sb3d      print *, 'Cloud base, c. top, CAPE',ICB,INB,cape
+c sb3d      print *, 'SIG ',(sig(i),i=1,inb)
+c sb3d      print *, 'W ',(w0(i),i=1,inb)
+c sb3d      print *, 'M ',(m(i), i=1,inb)
+c sb3d      print *, 'Dt1 ',(tvp(i)-tv(i),i=1,inb)
+c sb3d      print *, 'Dt_vrai ',(buoy(i),i=1,inb)
+Cjyg2
+C
+C   ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
+C   ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
+C   ***                        FRACTION (SIJ)                          ***
+C
+ 
+ 
+      DO 170 I=ICB,INB
+         RTI=RR(1)-EP(I)*CLW(I)
+         DO 160 J=ICB-1,INB
+            BF2=1.+LV(J)*LV(J)*RS(J)/(RV*T(J)*T(J)*CPD)
+            ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(RTI-RR(J))
+            DENOM=H(I)-HP(I)+(CPD-CPV)*(RR(I)-RTI)*T(J)
+            DEI=DENOM
+            IF(ABS(DEI).LT.0.01)DEI=0.01
+            SIJ(I,J)=ANUM/DEI
+            SIJ(I,I)=1.0
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM/BF2
+            CWAT=CLW(J)*(1.-EP(J))
+            STEMP=SIJ(I,J)
+            IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR.
+     1      ALTEM.GT.CWAT).AND.J.GT.I)THEN
+            ANUM=ANUM-LV(J)*(RTI-RS(J)-CWAT*BF2)
+            DENOM=DENOM+LV(J)*(RR(I)-RTI)
+            IF(ABS(DENOM).LT.0.01)DENOM=0.01
+            SIJ(I,J)=ANUM/DENOM
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM-(BF2-1.)*CWAT
+            END IF
+ 
+ 
+            IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.95)THEN
+               QENT(I,J)=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI
+               UENT(I,J)=SIJ(I,J)*U(I)+(1.-SIJ(I,J))*U(NK)
+               VENT(I,J)=SIJ(I,J)*V(I)+(1.-SIJ(I,J))*V(NK)
+               DO K=1,NTRA
+               TRAENT(I,J,K)=SIJ(I,J)*TRA(I,K)+(1.-SIJ(I,J))*
+     1         TRA(NK,K)
+               END DO
+               ELIJ(I,J)=ALTEM
+               ELIJ(I,J)=AMAX1(0.0,ELIJ(I,J))
+               MENT(I,J)=M(I)/(1.-SIJ(I,J))
+               NENT(I)=NENT(I)+1
+            END IF
+            SIJ(I,J)=AMAX1(0.0,SIJ(I,J))
+            SIJ(I,J)=AMIN1(1.0,SIJ(I,J))
+  160    CONTINUE
+C
+C   ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS  ***
+C   ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES  ***
+C
+         IF(NENT(I).EQ.0)THEN
+            MENT(I,I)=M(I)
+            QENT(I,I)=RR(NK)-EP(I)*CLW(I)
+           UENT(I,I)=U(NK)
+           VENT(I,I)=V(NK)
+           DO J=1,NTRA
+            TRAENT(I,I,J)=TRA(NK,J)
+           END DO
+            ELIJ(I,I)=CLW(I)
+            SIJ(I,I)=1.0
+         END IF
+C
+         DO J = ICB-1,INB
+           SIGIJ(I,J) = SIJ(I,J)
+         ENDDO
+C	
+  170 CONTINUE
+C
+C   ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
+C   ***              PROBABILITIES OF MIXING                     ***
+C
+ 
+      DO 200 I=ICB,INB
+      IF(NENT(I).NE.0)THEN
+       QP=RR(1)-EP(I)*CLW(I)
+       ANUM=H(I)-HP(I)-LV(I)*(QP-RS(I))+(CPV-CPD)*T(I)*
+     1    (QP-RR(I))
+       DENOM=H(I)-HP(I)+LV(I)*(RR(I)-QP)+
+     1    (CPD-CPV)*T(I)*(RR(I)-QP)
+       IF(ABS(DENOM).LT.0.01)DENOM=0.01
+       SCRIT=ANUM/DENOM
+       ALT=QP-RS(I)+SCRIT*(RR(I)-QP)
+       IF(SCRIT.LE.0.0.OR.ALT.LE.0.0)SCRIT=1.0
+       SMAX=0.0
+       ASIJ=0.0
+        DO 175 J=INB,ICB-1,-1
+        IF(SIJ(I,J).GT.1.0E-16.AND.SIJ(I,J).LT.0.95)THEN
+         WGH=1.0
+         IF(J.GT.I)THEN
+          SJMAX=AMAX1(SIJ(I,J+1),SMAX)
+          SJMAX=AMIN1(SJMAX,SCRIT)
+          SMAX=AMAX1(SIJ(I,J),SMAX)
+          SJMIN=AMAX1(SIJ(I,J-1),SMAX)
+          SJMIN=AMIN1(SJMIN,SCRIT)
+          IF(SIJ(I,J).LT.(SMAX-1.0E-16))WGH=0.0
+          SMID=AMIN1(SIJ(I,J),SCRIT)
+         ELSE
+          SJMAX=AMAX1(SIJ(I,J+1),SCRIT)
+          SMID=AMAX1(SIJ(I,J),SCRIT)
+          SJMIN=0.0
+          IF(J.GT.1)SJMIN=SIJ(I,J-1)
+          SJMIN=AMAX1(SJMIN,SCRIT)
+         END IF
+         DELP=ABS(SJMAX-SMID)
+         DELM=ABS(SJMIN-SMID)
+         ASIJ=ASIJ+WGH*(DELP+DELM)
+         MENT(I,J)=MENT(I,J)*(DELP+DELM)*WGH
+        END IF
+  175       CONTINUE
+       ASIJ=AMAX1(1.0E-16,ASIJ)
+       ASIJ=1.0/ASIJ
+       DO 180 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASIJ
+  180    CONTINUE
+       ASUM=0.0
+       BSUM=0.0
+       DO 190 J=ICB-1,INB
+        ASUM=ASUM+MENT(I,J)
+        MENT(I,J)=MENT(I,J)*SIG(J)
+        BSUM=BSUM+MENT(I,J)
+  190       CONTINUE
+       BSUM=AMAX1(BSUM,1.0E-16)
+       BSUM=1.0/BSUM
+       DO 195 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASUM*BSUM	
+  195       CONTINUE
+       CSUM=0.0
+       DO 197 J=ICB-1,INB
+        CSUM=CSUM+MENT(I,J)
+  197       CONTINUE
+ 
+       IF(CSUM.LT.M(I))THEN
+        NENT(I)=0
+        MENT(I,I)=M(I)
+        QENT(I,I)=RR(1)-EP(I)*CLW(I)
+          UENT(I,I)=U(NK)
+          VENT(I,I)=V(NK)
+          DO J=1,NTRA
+           TRAENT(I,I,J)=TRA(NK,J)
+          END DO
+        ELIJ(I,I)=CLW(I)
+        SIJ(I,I)=1.0
+       END IF
+      END IF
+  200      CONTINUE
+ 
+ 
+ 
+***************************************************************
+**       CALCUL DES MENTS(I,J) ET DES QENTS(I,J)
+**************************************************************
+ 
+         DO im=1,nd
+         do jm=1,nd
+ 
+         QENTS(im,jm)=QENT(im,jm)
+         MENTS(im,jm)=MENT(im,jm)
+         enddo
+         enddo
+ 
+***********************************************************
+c--- test sb:
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c@       write(*,*) 'inb,m(inb),ment(inb,inb),sigij(inb,inb):'
+c@       write(*,*) inb,m(inb),ment(inb,inb),sigij(inb,inb)
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c---
+
+ 
+ 
+ 
+C
+C   ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
+C   ***             DOWNDRAFT CALCULATION                      ***
+C
+        IF(EP(INB).LT.0.0001)GOTO 405
+C
+C   ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
+C   ***                AND CONDENSED WATER FLUX                    ***
+C
+        WFLUX=0.0
+        TINV=1./3.
+C
+C    ***                    BEGIN DOWNDRAFT LOOP                    ***
+C
+        DO 400 I=INB,1,-1
+C
+C    ***              CALCULATE DETRAINED PRECIPITATION             ***
+C
+ 
+ 
+        WDTRAIN=10.0*EP(I)*M(I)*CLW(I)
+        IF(I.GT.1)THEN
+         DO 320 J=1,I-1
+       AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+  320    WDTRAIN=WDTRAIN+10.0*AWAT*MENT(J,I)
+        END IF
+C
+C    ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
+C    ***              ESTIMATES OF RP(I)AND RP(I-1)             ***
+C
+ 
+ 
+        WT(I)=45.0
+      IF(I.LT.INB)THEN
+       RP(I)=RP(I+1)+(CPD*(T(I+1)-T(I))+GZ(I+1)-GZ(I))/LV(I)
+       RP(I)=0.5*(RP(I)+RR(I))
+      END IF
+      RP(I)=AMAX1(RP(I),0.0)
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(INB)=RR(INB)
+      IF(I.EQ.1)THEN
+       AFAC=P(1)*(RS(1)-RP(1))/(1.0E4+2000.0*P(1)*RS(1))
+      ELSE
+       RP(I-1)=RP(I)+(CPD*(T(I)-T(I-1))+GZ(I)-GZ(I-1))/LV(I)
+       RP(I-1)=0.5*(RP(I-1)+RR(I-1))
+       RP(I-1)=AMIN1(RP(I-1),RS(I-1))
+       RP(I-1)=AMAX1(RP(I-1),0.0)
+       AFAC1=P(I)*(RS(I)-RP(I))/(1.0E4+2000.0*P(I)*RS(I))
+       AFAC2=P(I-1)*(RS(I-1)-RP(I-1))/(1.0E4+
+     1    2000.0*P(I-1)*RS(I-1))
+       AFAC=0.5*(AFAC1+AFAC2)
+      END IF
+      IF(I.EQ.INB)AFAC=0.0
+        AFAC=AMAX1(AFAC,0.0)
+        BFAC=1./(SIGD*WT(I))
+C
+Cjyg1
+CCC        SIGT=1.0
+CCC        IF(I.GE.ICB)SIGT=SIGP(I)
+C Prise en compte de la variation progressive de SIGT dans
+C les couches ICB et ICB-1:
+C 	Pour PLCL<PH(I+1), PR1=0 & PR2=1
+C 	Pour PLCL>PH(I),   PR1=1 & PR2=0
+C 	Pour PH(I+1)<PLCL<PH(I), PR1 est la proportion a cheval
+C    sur le nuage, et PR2 est la proportion sous la base du
+C    nuage.
+         PR1 =(PLCL-PH(I+1))/(PH(I)-PH(I+1))
+         PR1 = MAX(0.,MIN(1.,PR1))
+         PR2 = (PH(I)-PLCL)/(PH(I)-PH(I+1))
+         PR2 = MAX(0.,MIN(1.,PR2))
+         SIGT = SIGP(I)*PR1 + PR2
+c sb3d         print *,'i,sigt,pr1,pr2', i,sigt,pr1,pr2
+Cjyg2
+C
+        B6=BFAC*50.*SIGD*(PH(I)-PH(I+1))*SIGT*AFAC
+        C6=WATER(I+1)+BFAC*WDTRAIN-50.*SIGD*BFAC*
+     1   (PH(I)-PH(I+1))*EVAP(I+1)
+      IF(C6.GT.0.0)THEN
+         REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
+         EVAP(I)=SIGT*AFAC*REVAP
+         WATER(I)=REVAP*REVAP
+      ELSE
+       EVAP(I)=-EVAP(I+1)+0.02*(WDTRAIN+SIGD*WT(I)*
+     1    WATER(I+1))/(SIGD*(PH(I)-PH(I+1)))
+      END IF
+ 
+ 
+C
+C    ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
+C    ***              HYDROSTATIC APPROXIMATION                 ***
+C
+        IF(I.EQ.1)GOTO 360
+      TEVAP=AMAX1(0.0,EVAP(I))
+      DELTH=AMAX1(0.001,(TH(I)-TH(I-1)))
+      MP(I)=10.*LVCP(I)*SIGD*TEVAP*(P(I-1)-P(I))/DELTH
+C
+C    ***           IF HYDROSTATIC ASSUMPTION FAILS,             ***
+C    ***   SOLVE CUBIC DIFFERENCE EQUATION FOR DOWNDRAFT THETA  ***
+C    ***  AND MASS FLUX FROM TWO SIMULTANEOUS DIFFERENTIAL EQNS ***
+C
+      AMFAC=SIGD*SIGD*70.0*PH(I)*(P(I-1)-P(I))*
+     1   (TH(I)-TH(I-1))/(TV(I)*TH(I))
+      AMP2=ABS(MP(I+1)*MP(I+1)-MP(I)*MP(I))
+      IF(AMP2.GT.(0.1*AMFAC))THEN
+         XF=100.0*SIGD*SIGD*SIGD*(PH(I)-PH(I+1))
+         TF=B(I)-5.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         AF=XF*TF+MP(I+1)*MP(I+1)*TINV
+         BF=2.*(TINV*MP(I+1))**3+TINV*MP(I+1)*XF*TF+50.*
+     1    (P(I-1)-P(I))*XF*TEVAP
+         FAC2=1.0
+         IF(BF.LT.0.0)FAC2=-1.0
+         BF=ABS(BF)
+         UR=0.25*BF*BF-AF*AF*AF*TINV*TINV*TINV
+         IF(UR.GE.0.0)THEN
+          SRU=SQRT(UR)
+          FAC=1.0
+          IF((0.5*BF-SRU).LT.0.0)FAC=-1.0
+          MP(I)=MP(I+1)*TINV+(0.5*BF+SRU)**TINV+
+     1     FAC*(ABS(0.5*BF-SRU))**TINV
+         ELSE
+          D=ATAN(2.*SQRT(-UR)/(BF+1.0E-28))
+          IF(FAC2.LT.0.0)D=3.14159-D
+          MP(I)=MP(I+1)*TINV+2.*SQRT(AF*TINV)*COS(D*TINV)
+         END IF
+         MP(I)=AMAX1(0.0,MP(I))
+         B(I-1)=B(I)+100.0*(P(I-1)-P(I))*TEVAP/(MP(I)+SIGD*0.1)-
+     1    10.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         B(I-1)=AMAX1(B(I-1),0.0)
+      END IF
+ 
+ 
+C
+C   ***         LIMIT MAGNITUDE OF MP(I) TO MEET CFL CONDITION      ***
+C
+      AMPMAX=2.0*(PH(I)-PH(I+1))*DELTI
+      AMP2=2.0*(PH(I-1)-PH(I))*DELTI
+      AMPMAX=AMIN1(AMPMAX,AMP2)
+      MP(I)=AMIN1(MP(I),AMPMAX)
+C
+C    ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
+C    ***       BETWEEN CLOUD BASE AND THE SURFACE                   ***
+C
+          IF(P(I).GT.P(ICB))THEN
+           MP(I)=MP(ICB)*(P(1)-P(I))/(P(1)-P(ICB))
+          END IF
+  360   CONTINUE
+C
+C    ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
+C
+        IF(I.EQ.INB)GOTO 400
+      RP(I)=RR(I)
+        IF(MP(I).GT.MP(I+1))THEN
+        RP(I)=RP(I+1)*MP(I+1)+RR(I)*(MP(I)-MP(I+1))+
+     1       5.*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+EVAP(I))
+        RP(I)=RP(I)/MP(I)
+          UP(I)=UP(I+1)*MP(I+1)+U(I)*(MP(I)-MP(I+1))
+         UP(I)=UP(I)/MP(I)
+          VP(I)=VP(I+1)*MP(I+1)+V(I)*(MP(I)-MP(I+1))
+         VP(I)=VP(I)/MP(I)
+          DO J=1,NTRA
+           TRAP(I,J)=TRAP(I+1,J)*MP(I+1)+
+     s     TRAP(I,J)*(MP(I)-MP(I+1))
+           TRAP(I,J)=TRAP(I,J)/MP(I)
+          END DO
+        ELSE
+        IF(MP(I+1).GT.1.0E-16)THEN
+           RP(I)=RP(I+1)+5.0*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+
+     1      EVAP(I))/MP(I+1)
+            UP(I)=UP(I+1)
+            VP(I)=VP(I+1)
+            DO J=1,NTRA
+             TRAP(I,J)=TRAP(I+1,J)
+            END DO
+        END IF
+        END IF
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(I)=AMAX1(RP(I),0.0)
+  400   CONTINUE
+C
+C   ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
+C
+        PRECIP=WT(1)*SIGD*WATER(1)*8640.0
+
+c sb  ***  Calculate downdraft velocity scale and surface temperature and  ***
+c sb  ***                    water vapor fluctuations                      ***
+c sb		(inspire de convect 4.3)
+
+c       BETAD=10.0         
+       BETAD=5.0         
+       WD=BETAD*ABS(MP(ICB))*0.01*RD*T(ICB)/(SIGD*P(ICB))
+
+  405   CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
+C   ***                      AND MIXING RATIO                        ***
+C
+      DPINV=1.0/(PH(1)-PH(2))
+        AM=0.0
+        DO 410 K=2,INB
+  410   AM=AM+M(K)
+      IF((0.1*DPINV*AM).GE.DELTI)IFLAG=4
+      FT(1)=0.1*DPINV*AM*(T(2)-T(1)+(GZ(2)-GZ(1))/CPN(1))
+        FT(1)=FT(1)-0.5*LVCP(1)*SIGD*(EVAP(1)+EVAP(2))
+        FT(1)=FT(1)-0.09*SIGD*MP(2)*T(1)*B(1)*DPINV
+      FT(1)=FT(1)+0.01*SIGD*WT(1)*(CL-CPD)*WATER(2)*(T(2)-
+     1   T(1))*DPINV/CPN(1)
+        FR(1)=0.1*MP(2)*(RP(2)-RR(1))*
+Ccorrection bug conservation eau
+C    1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+     1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+cIM cf. SBL
+C    1    DPINV+SIGD*EVAP(1)
+        FR(1)=FR(1)+0.1*AM*(RR(2)-RR(1))*DPINV
+        FU(1)=FU(1)+0.1*DPINV*(MP(2)*(UP(2)-U(1))+AM*(U(2)-U(1)))
+        FV(1)=FV(1)+0.1*DPINV*(MP(2)*(VP(2)-V(1))+AM*(V(2)-V(1)))
+        DO J=1,NTRA
+         FTRA(1,J)=FTRA(1,J)+0.1*DPINV*(MP(2)*(TRAP(2,J)-TRA(1,J))+
+     1    AM*(TRA(2,J)-TRA(1,J)))
+        END DO
+        AMDE=0.0
+        DO 415 J=2,INB
+         FR(1)=FR(1)+0.1*DPINV*MENT(J,1)*(QENT(J,1)-RR(1))
+         FU(1)=FU(1)+0.1*DPINV*MENT(J,1)*(UENT(J,1)-U(1))
+         FV(1)=FV(1)+0.1*DPINV*MENT(J,1)*(VENT(J,1)-V(1))
+         DO K=1,NTRA
+          FTRA(1,K)=FTRA(1,K)+0.1*DPINV*MENT(J,1)*(TRAENT(J,1,K)-
+     1     TRA(1,K))
+         END DO
+  415      CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
+C   ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
+C
+C   ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
+C   ***                      THROUGH EACH LEVEL                          ***
+C
+ 
+ 
+        DO 500 I=2,INB
+        DPINV=1.0/(PH(I)-PH(I+1))
+      CPINV=1.0/CPN(I)
+        AMP1=0.0
+        DO 440 K=I+1,INB+1
+  440   AMP1=AMP1+M(K)
+        DO 450 K=1,I
+        DO 450 J=I+1,INB+1
+         AMP1=AMP1+MENT(K,J)
+  450   CONTINUE
+      IF((0.1*DPINV*AMP1).GE.DELTI)IFLAG=4
+        AD=0.0
+        DO 470 K=1,I-1
+        DO 470 J=I,INB
+  470   AD=AD+MENT(J,K)
+      FT(I)=0.1*DPINV*(AMP1*(T(I+1)-T(I)+(GZ(I+1)-GZ(I))*
+     1   CPINV)-AD*(T(I)-T(I-1)+(GZ(I)-GZ(I-1))*CPINV))
+     2   -0.5*SIGD*LVCP(I)*(EVAP(I)+EVAP(I+1))
+      RAT=CPN(I-1)*CPINV
+        FT(I)=FT(I)-0.09*SIGD*(MP(I+1)*T(I)*
+     1    B(I)-MP(I)*T(I-1)*RAT*B(I-1))*DPINV
+      FT(I)=FT(I)+0.1*DPINV*MENT(I,I)*(HP(I)-H(I)+
+     1    T(I)*(CPV-CPD)*(RR(I)-QENT(I,I)))*CPINV
+      FT(I)=FT(I)+0.01*SIGD*WT(I)*(CL-CPD)*WATER(I+1)*
+     1    (T(I+1)-T(I))*DPINV*CPINV
+        FR(I)=0.1*DPINV*(AMP1*(RR(I+1)-RR(I))-
+     1    AD*(RR(I)-RR(I-1)))
+        FU(I)=FU(I)+0.1*DPINV*(AMP1*(U(I+1)-U(I))-
+     1    AD*(U(I)-U(I-1)))
+        FV(I)=FV(I)+0.1*DPINV*(AMP1*(V(I+1)-V(I))-
+     1    AD*(V(I)-V(I-1)))
+        DO K=1,NTRA
+         FTRA(I,K)=FTRA(I,K)+0.1*DPINV*(AMP1*(TRA(I+1,K)-
+     1    TRA(I,K))-AD*(TRA(I,K)-TRA(I-1,K)))
+        END DO
+        DO 480 K=1,I-1
+       AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+         FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-AWAT
+     1    -RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+C (saturated updrafts resulting from mixing)      ! cld   
+         QCOND(I)=QCOND(I)+(ELIJ(K,I)-AWAT)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  480   CONTINUE
+      DO 490 K=I,INB
+       FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  490      CONTINUE
+        FR(I)=FR(I)+0.5*SIGD*(EVAP(I)+EVAP(I+1))+0.1*(MP(I+1)*
+     1    (RP(I+1)-RR(I))-MP(I)*(RP(I)-RR(I-1)))*DPINV
+        FU(I)=FU(I)+0.1*(MP(I+1)*(UP(I+1)-U(I))-MP(I)*
+     1    (UP(I)-U(I-1)))*DPINV
+        FV(I)=FV(I)+0.1*(MP(I+1)*(VP(I+1)-V(I))-MP(I)*
+     1    (VP(I)-V(I-1)))*DPINV
+        DO J=1,NTRA
+         FTRA(I,J)=FTRA(I,J)+0.1*DPINV*(MP(I+1)*(TRAP(I+1,J)-TRA(I,J))-
+     1    MP(I)*(TRAP(I,J)-TRAP(I-1,J)))
+        END DO
+C (saturated downdrafts resulting from mixing)    ! cld
+        DO K=I+1,INB                              ! cld
+         QCOND(I)=QCOND(I)+ELIJ(K,I)              ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDDO                                     ! cld
+C (particular case: no detraining level is found) ! cld
+        IF (NENT(I).EQ.0) THEN                    ! cld
+         QCOND(I)=QCOND(I)+(1-EP(I))*CLW(I)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDIF                                     ! cld
+        IF (NQCOND(I).NE.0.) THEN                 ! cld
+         QCOND(I)=QCOND(I)/NQCOND(I)              ! cld
+        ENDIF                                     ! cld
+  500   CONTINUE
+ 
+ 
+ 
+C
+C   ***   MOVE THE DETRAINMENT AT LEVEL INB DOWN TO LEVEL INB-1   ***
+C   ***        IN SUCH A WAY AS TO PRESERVE THE VERTICALLY        ***
+C   ***          INTEGRATED ENTHALPY AND WATER TENDENCIES         ***
+C
+c test sb:
+c@      write(*,*) '--------------------------------------------'
+c@      write(*,*) 'inb,ft,hp,h,t,rr,qent,ment,water,waterp,wt,mp,b'
+c@      write(*,*) inb,ft(inb),hp(inb),h(inb)
+c@     :   ,t(inb),rr(inb),qent(inb,inb)
+c@     :   ,ment(inb,inb),water(inb)
+c@     :   ,water(inb+1),wt(inb),mp(inb),b(inb)
+c@      write(*,*) '--------------------------------------------'
+c fin test sb:
+
+      AX=0.1*MENT(INB,INB)*(HP(INB)-H(INB)+T(INB)*
+     1    (CPV-CPD)*(RR(INB)-QENT(INB,INB)))/(CPN(INB)*
+     2    (PH(INB)-PH(INB+1)))
+      FT(INB)=FT(INB)-AX
+      FT(INB-1)=FT(INB-1)+AX*CPN(INB)*(PH(INB)-PH(INB+1))/
+     1    (CPN(INB-1)*(PH(INB-1)-PH(INB)))
+      BX=0.1*MENT(INB,INB)*(QENT(INB,INB)-RR(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FR(INB)=FR(INB)-BX
+      FR(INB-1)=FR(INB-1)+BX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      CX=0.1*MENT(INB,INB)*(UENT(INB,INB)-U(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FU(INB)=FU(INB)-CX
+      FU(INB-1)=FU(INB-1)+CX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DX=0.1*MENT(INB,INB)*(VENT(INB,INB)-V(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FV(INB)=FV(INB)-DX
+      FV(INB-1)=FV(INB-1)+DX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DO J=1,NTRA
+      EX=0.1*MENT(INB,INB)*(TRAENT(INB,INB,J)
+     1    -TRA(INB,J))/(PH(INB)-PH(INB+1))
+      FTRA(INB,J)=FTRA(INB,J)-EX
+      FTRA(INB-1,J)=FTRA(INB-1,J)+EX*
+     1     (PH(INB)-PH(INB+1))/(PH(INB-1)-PH(INB))
+      ENDDO   
+C
+C   ***    HOMOGINIZE TENDENCIES BELOW CLOUD BASE    ***
+C
+      ASUM=0.0
+      BSUM=0.0
+      CSUM=0.0
+        DSUM=0.0
+      DO 650 I=1,ICB-1
+       ASUM=ASUM+FT(I)*(PH(I)-PH(I+1))
+         BSUM=BSUM+FR(I)*(LV(I)+(CL-CPD)*(T(I)-T(1)))*
+     1    (PH(I)-PH(I+1))
+       CSUM=CSUM+(LV(I)+(CL-CPD)*(T(I)-T(1)))*(PH(I)-PH(I+1))
+       DSUM=DSUM+T(I)*(PH(I)-PH(I+1))/TH(I)
+  650      CONTINUE
+      DO 700 I=1,ICB-1
+       FT(I)=ASUM*T(I)/(TH(I)*DSUM)
+       FR(I)=BSUM/CSUM
+  700      CONTINUE
+C
+C   ***           RESET COUNTER AND RETURN           ***
+C
+      SIG(ND)=2.0
+c
+c
+      do i = 1, nd
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+c sb       dnwd0(i) = - mp(i)
+      enddo
+c
+      do i = 1, nl
+       dnwd0(i) = - mp(i)
+      enddo
+      do i = nl+1, nd
+       dnwd0(i) = 0.
+      enddo
+c
+      do i = icb, inb
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+
+         do k =i, inb
+            up1=0.0
+            dn1=0.0
+            do n = 1, i-1
+               up1 = up1 + ment(n,k)
+               dn1 = dn1 - ment(k,n)
+            enddo
+            upwd(i) = upwd(i)+ m(k) + up1
+            dnwd(i) = dnwd(i) + dn1
+         enddo
+        enddo
+ 
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        DETERMINATION DE LA VARIATION DE FLUX ASCENDANT ENTRE
+C        DEUX NIVEAU NON DILUE Mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+c sb      do i=1,ND
+c sb      Mike(i)=M(i)
+c sb      enddo
+ 
+      do i = 1, NL
+       Mike(i) = M(i)
+      enddo
+      do i = NL+1, ND
+       Mike(i) = 0.
+      enddo
+ 
+      do i=1,nd
+      Ma(i)=0
+      enddo
+ 
+c sb      do i=1,nd
+c sb      do j=i,nd
+c sb      Ma(i)=Ma(i)+M(j)
+c sb      enddo
+c sb      enddo
+
+      do i = 1, NL
+      do j = i, NL
+       Ma(i) = Ma(i) + M(j)
+      enddo
+      enddo
+c
+      do i = NL+1, ND
+       Ma(i) = 0.
+      enddo
+c 
+      do i=1,ICB-1
+      Ma(i)=0
+      enddo
+ 
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C        ICB REPRESENTE DE NIVEAU OU SE TROUVE LA
+c        BASE DU NUAGE , ET INB LE TOP DU NUAGE
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+       do i=1,ND
+       Mke(i)=upwd(i)+dnwd(i)
+       enddo
+
+C
+C   *** Diagnose the in-cloud mixing ratio   ***              ! cld
+C   ***           of condensed water         ***              ! cld
+C                                                             ! cld
+       DO I=1,ND                                              ! cld
+        MAA(I)=0.0                                            ! cld
+        WA(I)=0.0                                             ! cld
+        SIGA(I)=0.0                                           ! cld
+       ENDDO                                                  ! cld
+       DO I=NK,INB                                            ! cld
+       DO K=I+1,INB+1                                         ! cld
+        MAA(I)=MAA(I)+M(K)                                    ! cld
+       ENDDO                                                  ! cld
+       ENDDO                                                  ! cld
+       DO I=ICB,INB-1                                         ! cld
+        AXC(I)=0.                                             ! cld
+        DO J=ICB,I                                            ! cld
+         AXC(I)=AXC(I)+RD*(TVP(J)-TV(J))*(PH(J)-PH(J+1))/P(J) ! cld
+        ENDDO                                                 ! cld
+        IF (AXC(I).GT.0.0) THEN                               ! cld
+         WA(I)=SQRT(2.*AXC(I))                                ! cld
+        ENDIF                                                 ! cld
+       ENDDO                                                  ! cld
+       DO I=1,NL                                              ! cld
+        IF (WA(I).GT.0.0)                                     ! cld
+     1    SIGA(I)=MAA(I)/WA(I)*RD*TVP(I)/P(I)/100./DELTAC     ! cld
+        SIGA(I) = MIN(SIGA(I),1.0)                            ! cld
+        QCONDC(I)=SIGA(I)*CLW(I)*(1.-EP(I))                   ! cld
+     1          + (1.-SIGA(I))*QCOND(I)                       ! cld
+       ENDDO                                                  ! cld
+
+
+c@$$cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c@$$         call writeg1d(1,klev,ma,'ma  ','ma  ')
+c@$$          call writeg1d(1,klev,upwd,'upwd  ','upwd  ')
+c@$$          call writeg1d(1,klev,dnwd,'dnwd  ','dnwd  ')
+c@$$          call writeg1d(1,klev,dnwd0,'dnwd0  ','dnwd0  ')
+c@$$          call writeg1d(1,klev,tvp,'tvp  ','tvp  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,3),'tra3  ','tra3  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,4),'tra4  ','tra4  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,5),'tra5  ','tra5  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,6),'tra6  ','tra6  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,7),'tra7  ','tra7  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,8),'tra8  ','tra8  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,9),'tra9  ','tra9  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,10),'tra10','tra10')
+c@$$          call writeg1d(1,klev,tra(1:klev,11),'tra11','tra11')
+c@$$          call writeg1d(1,klev,tra(1:klev,12),'tra12','tra12')
+c@$$          call writeg1d(1,klev,tra(1:klev,13),'tra13','tra13')
+c@$$          call writeg1d(1,klev,tra(1:klev,14),'tra14','tra14')
+c@$$          call writeg1d(1,klev,tra(1:klev,15),'tra15','tra15')
+c@$$          call writeg1d(1,klev,tra(1:klev,16),'tra16','tra16')
+c@$$          call writeg1d(1,klev,tra(1:klev,17),'tra17','tra17')
+c@$$          call writeg1d(1,klev,tra(1:klev,18),'tra18','tra18')
+c@$$          call writeg1d(1,klev,tra(1:klev,19),'tra19','tra19')
+c@$$          call writeg1d(1,klev,tra(1:klev,20),'tra20','tra20 ')
+c@$$          call writeg1d(1,klev,trap(1:klev,1),'trp1','trp1')
+c@$$          call writeg1d(1,klev,trap(1:klev,2),'trp2','trp2')
+c@$$          call writeg1d(1,klev,trap(1:klev,3),'trp3','trp3')
+c@$$          call writeg1d(1,klev,trap(1:klev,4),'trp4','trp4')
+c@$$          call writeg1d(1,klev,trap(1:klev,5),'trp5','trp5')
+c@$$          call writeg1d(1,klev,trap(1:klev,10),'trp10','trp10')
+c@$$          call writeg1d(1,klev,trap(1:klev,12),'trp12','trp12')
+c@$$          call writeg1d(1,klev,trap(1:klev,15),'trp15','trp15')
+c@$$          call writeg1d(1,klev,trap(1:klev,20),'trp20','trp20')
+c@$$          call writeg1d(1,klev,ftra(1:klev,1),'ftr1  ','ftr1  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,2),'ftr2  ','ftr2  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,3),'ftr3  ','ftr3  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,4),'ftr4  ','ftr4  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,5),'ftr5  ','ftr5  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,6),'ftr6  ','ftr6  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,7),'ftr7  ','ftr7  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,8),'ftr8  ','ftr8  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,9),'ftr9  ','ftr9  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,10),'ftr10','ftr10')
+c@$$          call writeg1d(1,klev,ftra(1:klev,11),'ftr11','ftr11')
+c@$$          call writeg1d(1,klev,ftra(1:klev,12),'ftr12','ftr12')
+c@$$          call writeg1d(1,klev,ftra(1:klev,13),'ftr13','ftr13')
+c@$$          call writeg1d(1,klev,ftra(1:klev,14),'ftr14','ftr14')
+c@$$          call writeg1d(1,klev,ftra(1:klev,15),'ftr15','ftr15')
+c@$$          call writeg1d(1,klev,ftra(1:klev,16),'ftr16','ftr16')
+c@$$          call writeg1d(1,klev,ftra(1:klev,17),'ftr17','ftr17')
+c@$$          call writeg1d(1,klev,ftra(1:klev,18),'ftr18','ftr18')
+c@$$          call writeg1d(1,klev,ftra(1:klev,19),'ftr19','ftr19')
+c@$$          call writeg1d(1,klev,ftra(1:klev,20),'ftr20','ftr20 ')
+c@$$          call writeg1d(1,klev,mp,'mp  ','mp ')
+c@$$          call writeg1d(1,klev,Mke,'Mke  ','Mke ')
+
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c
+        RETURN
+        END
+C ---------------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cpl_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cpl_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cpl_mod.F90	(revision 984)
@@ -0,0 +1,1223 @@
+!
+! $Header$
+!
+MODULE cpl_mod
+!
+! This module excahanges and transforms all fields that should be recieved or sent to 
+! coupler. The transformation of the fields are done from the grid 1D-array in phylmd 
+! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each 
+! timestep is done in here. 
+!
+! Each type of surface that recevie fields from the coupler have a subroutine named 
+! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler 
+! have a subroutine named cpl_send_XXX_fields.
+!
+!*************************************************************************************
+
+! Use statements
+!*************************************************************************************
+  USE dimphy, ONLY : klon
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  USE iophy
+
+! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters 
+! in the module are compiled and not the subroutines.
+  USE oasis
+  USE write_field_phy
+  
+! Global attributes
+!*************************************************************************************
+  IMPLICIT NONE
+  PRIVATE
+
+  ! All subroutine are public except cpl_send_all and cpl_receive_all
+  PUBLIC :: cpl_init, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
+       cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
+       cpl_send_landice_fields, gath2cpl
+  
+
+! Declaration of module variables
+!*************************************************************************************
+! variable for coupling period
+  INTEGER, SAVE                             :: nexca
+  !$OMP THREADPRIVATE(nexca)
+
+! variables for cumulating fields during a coupling periode :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_sols, cpl_nsol, cpl_rain
+  !$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_snow, cpl_evap, cpl_tsol
+  !$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_fder, cpl_albe, cpl_taux
+  !$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp
+  !$OMP THREADPRIVATE(cpl_windsp)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_tauy
+  !$OMP THREADPRIVATE(cpl_tauy)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
+  !$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
+
+! variables read from coupler :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sst     ! sea surface temperature
+  !$OMP THREADPRIVATE(read_sst)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sit     ! sea ice temperature
+  !$OMP THREADPRIVATE(read_sit)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sic     ! sea ice fraction
+  !$OMP THREADPRIVATE(read_sic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_alb_sic ! albedo at sea ice
+  !$OMP THREADPRIVATE(read_alb_sic)
+  
+! fraction for different surface, saved during whole coupling period
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: pctsrf_sav   
+  !$OMP THREADPRIVATE(pctsrf_sav)
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: unity
+  !$OMP THREADPRIVATE(unity)
+  INTEGER, SAVE                             :: nidct, nidcs
+  !$OMP THREADPRIVATE(nidct,nidcs)
+
+! variables to be sent to the coupler
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
+  !$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
+  !$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
+  !$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
+  !$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp2D
+  !$OMP THREADPRIVATE(cpl_windsp2D)
+  
+
+CONTAINS
+!
+!************************************************************************************
+!
+  SUBROUTINE cpl_init(dtime, rlon, rlat)
+
+    INCLUDE "dimensions.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "control.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER                           :: error, sum_error, ig, i
+    INTEGER                           :: jf, nhoridct
+    INTEGER                           :: nhoridcs
+    INTEGER                           :: idtime
+    INTEGER                           :: idayref
+    INTEGER                           :: npas ! only for OASIS2
+    REAL                              :: zjulian
+    REAL, DIMENSION(iim,jjm+1)        :: zx_lon, zx_lat
+    CHARACTER(len = 20)               :: modname = 'cpl_init'
+    CHARACTER(len = 80)               :: abort_message
+    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
+
+!*************************************************************************************
+! Calculate coupling period
+!
+!*************************************************************************************
+     
+    npas = itaufin/ iphysiq
+    nexca = 86400 / dtime
+    WRITE(lunout,*)' ##### Ocean couple #####'
+    WRITE(lunout,*)' Valeurs des pas de temps'
+    WRITE(lunout,*)' npas = ', npas
+    WRITE(lunout,*)' nexca = ', nexca
+    
+!*************************************************************************************
+! Allocate variables
+!
+!*************************************************************************************
+    error = 0
+    sum_error = 0
+
+    ALLOCATE(unity(klon), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(pctsrf_sav(klon,nbsrf), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_sols(klon,2), stat = error) 
+    sum_error = sum_error + error
+    ALLOCATE(cpl_nsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rain(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_snow(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_evap(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_fder(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_albe(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_taux(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_windsp(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tauy(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sst(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sit(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+
+    IF (sum_error /= 0) THEN
+       abort_message='Pb allocation variables couplees'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+!*************************************************************************************
+! Initialize the allocated varaibles
+!
+!*************************************************************************************
+    DO ig = 1, klon
+       unity(ig) = ig
+    ENDDO
+    pctsrf_sav = 0.
+
+    cpl_sols = 0.   ; cpl_nsol = 0.  ; cpl_rain = 0.   ; cpl_snow = 0.
+    cpl_evap = 0.   ; cpl_tsol = 0.  ; cpl_fder = 0.   ; cpl_albe = 0.
+    cpl_taux = 0.   ; cpl_tauy = 0.  ; cpl_rriv2D = 0. ; cpl_rcoa2D = 0.
+    cpl_rlic2D = 0. ; cpl_windsp = 0.
+
+!*************************************************************************************
+! Initialize coupling
+!
+!*************************************************************************************
+    idtime = INT(dtime)
+#ifdef CPP_COUPLE
+    CALL inicma
+#endif
+
+!*************************************************************************************
+! initialize NetCDF output
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       idayref = day_ini
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+       DO i = 1, iim
+          zx_lon(i,1) = rlon(i+1)
+          zx_lon(i,jjm+1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+       clintocplnam="cpl_atm_tauflx"
+       CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
+            1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct) 
+! no vertical axis
+       CALL histdef(nidct, 'tauxe','tauxe', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tauyn','tauyn', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lon','tmp_lon', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lat','tmp_lat', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       DO jf=1,jpflda2o1 + jpflda2o2
+          CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
+               "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidct)
+       CALL histsync(nidct)
+       
+       clfromcplnam="cpl_atm_sst"
+       CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
+            0,zjulian,dtime,nhoridcs,nidcs) 
+! no vertical axis
+       DO jf=1,jpfldo2a
+          CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
+               "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidcs)
+       CALL histsync(nidcs)
+
+    ENDIF    ! is_sequential
+    
+  END SUBROUTINE cpl_init
+  
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_receive_all(itime, dtime, pctsrf)
+! This subroutine reads from coupler for both ocean and seaice
+! 4 fields : read_sst, read_sic, read_sit and read_alb_sic. 
+
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Local variables
+!************************************************************************************
+    INTEGER                                 :: j, ig, il_time_secs
+    INTEGER                                 :: itau_w
+    INTEGER, DIMENSION(iim*(jjm+1))         :: ndexcs
+    CHARACTER(len = 20)                     :: modname = 'cpl_receive_all'
+    CHARACTER(len = 80)                     :: abort_message
+    REAL, DIMENSION(klon)                   :: read_sic1D
+    REAL, DIMENSION(iim,jj_nb,jpfldo2a)  :: tab_read_flds
+    REAL, DIMENSION(iim,jj_nb)           :: read_sic
+
+!*************************************************************************************
+! Start calculation
+! Get fields from coupler
+!
+!*************************************************************************************
+
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL fromcpl(il_time_secs, tab_read_flds)
+#endif
+    
+! NetCDF output of received fields
+    IF (is_sequential) THEN
+       ndexcs(:) = 0
+       itau_w = itau_phy + itime
+       DO ig = 1, jpfldo2a
+          CALL histwrite(nidcs,cl_read(ig),itau_w,tab_read_flds(:,:,ig),iim*(jjm+1),ndexcs)
+       END DO
+    ENDIF
+
+! Save each field in a 2D array. 
+    read_sst(:,:)     = tab_read_flds(:,:,1)  ! Sea surface temperature
+    read_sic(:,:)     = tab_read_flds(:,:,2)  ! Sea ice concentration
+    read_alb_sic(:,:) = tab_read_flds(:,:,3)  ! Albedo at sea ice
+    read_sit(:,:)     = tab_read_flds(:,:,4)  ! Sea ice temperature
+
+!*************************************************************************************
+! Temperature and albedo are weighted with the fraction of sea-ice(read-sic)
+!
+!*************************************************************************************
+    DO j = 1, jj_nb
+       DO ig = 1, iim
+          IF (ABS(1. - read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = RTT - 1.8
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ELSE IF (ABS(read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sst(ig,j)
+             read_alb_sic(ig,j) =  0.6
+          ELSE
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ENDIF
+       ENDDO
+    ENDDO
+    
+!*************************************************************************************
+!  Transform seaice fraction, read_sic into pctsrf_sav
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sic, read_sic1D, klon, unity)
+
+    DO ig = 1, klon
+       ! treatment only of ocean and/or seaice points
+       IF (pctsrf(ig,is_oce) > epsfra .OR. &
+            pctsrf(ig,is_sic) > epsfra) THEN
+          pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               * read_sic1D(ig)
+          pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               - pctsrf_sav(ig,is_sic)
+       ENDIF
+    ENDDO
+
+!*************************************************************************************
+! To avoid round up problems
+!
+!*************************************************************************************
+    WHERE (ABS(pctsrf_sav(:,is_sic)) .LE. 2.*EPSILON(pctsrf_sav(1,is_sic)))
+       pctsrf_sav(:,is_sic) = 0.
+       pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+    ENDWHERE
+    WHERE (ABS(pctsrf_sav(:,is_oce)) .LE. 2.*EPSILON(pctsrf_sav(1,is_oce)))
+       pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+       pctsrf_sav(:,is_oce) = 0.
+    ENDWHERE
+    IF (MINVAL(pctsrf_sav(:,is_oce)) < 0.) THEN
+       WRITE(*,*)'Pb fraction ocean inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_oce))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_oce)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    IF (MINVAL(pctsrf_sav(:,is_sic)) < 0.) THEN
+       WRITE(*,*)'Pb fraction glace inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_sic))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_sic)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+        
+  END SUBROUTINE cpl_receive_all
+!
+!*************************************************************************************
+! 
+  SUBROUTINE cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf, &
+       tsurf_new, pctsrf_oce)
+!
+! This routine reads, if first time step in a coupling period, all fields reveived from
+! coupler for all types of surfaces. It returns the fields for the ocean surface which
+! are the sea surface temperature and the fraction of ocean. 
+! The fields are transformed into 1D arrays with valid points : 
+! tsurf_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_oce
+
+!*************************************************************************************
+! If first time step in a coupling period receive all fields for all types
+! of surfaces from coupler : read_sst, read_sit, read_alb_sic and pctsrf_sav. 
+! 
+!*************************************************************************************
+
+    IF (MOD(itime, nexca) == 1) CALL cpl_receive_all(itime, dtime, pctsrf)
+
+
+!*************************************************************************************
+! Transform read_sst into compressed 1D variable tsurf_new
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sst, tsurf_new, knon, knindex)
+    pctsrf_oce(:) = pctsrf_sav(:,is_oce) 
+
+
+  END SUBROUTINE cpl_receive_ocean_fields
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl_receive_seaice_fields(knon, knindex, &
+       tsurf_new, alb_new, pctsrf_sic)
+!
+! This routine returns the fields for the seaice that have been read from the coupler
+! (done earlier with cpl_receive_ocean_fields). These fields are the temperature and 
+! albedo at sea ice surface and fraction of sea ice.
+! The fields are transformed into  1D arrays with valid points : 
+! tsurf_new(1:knon), alb_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_sic
+
+
+!*************************************************************************************
+! Transform fields read from coupler from 2D into compressed 1D variables
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sit, tsurf_new, knon, knindex)
+    CALL cpl2gath(read_alb_sic, alb_new, knon, knindex)
+    pctsrf_sic(:) = pctsrf_sav(:,is_sic) 
+
+  END SUBROUTINE cpl_receive_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder, albsol
+    REAL, DIMENSION(klon), INTENT(IN)       :: taux, tauy, windsp
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_ocean_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+!*************************************************************************************
+! Start calculation
+! The ocean points are saved with second array index=1
+!
+!*************************************************************************************
+    cpl_index = 1
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+       cpl_windsp(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+       cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
+            windsp(ig)      / FLOAT(nexca) 
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid. 
+! No sending to the coupler (it is done from cpl_send_seaice_fields).
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)!
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_windsp(1,cpl_index), cpl_windsp2D(1,1), &
+            knon, knindex)
+
+    ENDIF
+
+  END SUBROUTINE cpl_send_ocean_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. All fields for all types of surfaces are sent to
+! the coupler.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder
+    REAL, DIMENSION(klon), INTENT(IN)       :: albsol, taux, tauy
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+    LOGICAL, INTENT(IN)                     :: lafin
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_seaice_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+
+!*************************************************************************************
+! Start calulation
+! The sea-ice points are saved with second array index=2
+!
+!*************************************************************************************
+    cpl_index = 2
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid and all fields are sent to coupler.
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       ! Send all fields
+       CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+    ENDIF
+
+  END SUBROUTINE cpl_send_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rriv_in
+    REAL, DIMENSION(klon), INTENT(IN)         :: rcoa_in
+
+! Local variables
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rriv2D
+    REAL, DIMENSION(iim,jj_nb)             :: rcoa2D
+
+!*************************************************************************************
+! Rearrange fields in 2D variables 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rriv2D(:,:) = 0.0
+    rcoa2D(:,:) = 0.0
+    CALL gath2cpl(rriv_in, rriv2D, knon, knindex)
+    CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex)
+
+!*************************************************************************************
+! Reset cumulated fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rriv2D(:,:) = 0.0
+       cpl_rcoa2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Following fields should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca)
+    cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_land_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in)
+! This subroutine cumulates the field for melting ice for each time-step 
+! during a coupling period. This routine will not send to coupler. Sending 
+! will be done in cpl_send_seaice_fields.
+!
+    INCLUDE "dimensions.h"
+    
+! Input varibales
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlic_in
+
+! Local varibales
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rlic2D
+
+!*************************************************************************************
+! Rearrange field in a 2D variable 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rlic2D(:,:) = 0.0
+    CALL gath2cpl(rlic_in, rlic2D, knon, knindex)
+
+!*************************************************************************************
+! Reset field to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rlic2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Melting ice should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_landice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+! This routine will send fields for all different surfaces to the coupler.
+! This subroutine should be executed after calculations by the last surface(sea-ice),
+! all calculations at the different surfaces have to be done before. 
+!    
+! Some includes
+!*************************************************************************************
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                                  :: itime
+    REAL, INTENT(IN)                                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)                    :: rlon, rlat
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)              :: pctsrf
+    LOGICAL, INTENT(IN)                                  :: lafin
+    
+! Local variables
+!*************************************************************************************
+    INTEGER                                              :: error, sum_error, j
+    INTEGER                                              :: itau_w
+    INTEGER                                              :: il_time_secs
+    INTEGER, DIMENSION(iim*(jjm+1))                      :: ndexct
+    REAL                                                 :: Up, Down
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_lon, tmp_lat
+    REAL, DIMENSION(iim, jj_nb, 4)                       :: pctsrf2D
+    REAL, DIMENSION(iim, jj_nb)                          :: deno
+    CHARACTER(len = 20)                                  :: modname = 'cpl_send_all'
+    CHARACTER(len = 80)                                  :: abort_message
+   
+! Variables with fields to coupler
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_taux
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_tauy
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_calv
+! Table with all fields to send to coupler
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2)     :: tab_flds
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
+#endif
+
+! End definitions
+!*************************************************************************************
+    
+
+
+!*************************************************************************************
+! All fields are stored in a table tab_flds(:,:,:)
+! First store the fields 7 to 18 which are already on the right format
+!
+!*************************************************************************************
+    tab_flds(:,:,7)  = cpl_windsp2D(:,:)
+    tab_flds(:,:,8)  = cpl_sols2D(:,:,2)
+    tab_flds(:,:,9)  = cpl_sols2D(:,:,1)
+    tab_flds(:,:,10) = cpl_nsol2D(:,:,2)
+    tab_flds(:,:,11) = cpl_nsol2D(:,:,1)
+    tab_flds(:,:,12) = cpl_fder2D(:,:,2)
+    tab_flds(:,:,13) = cpl_evap2D(:,:,2)
+    tab_flds(:,:,14) = cpl_evap2D(:,:,1)
+    tab_flds(:,:,17) = cpl_rcoa2D(:,:)
+    tab_flds(:,:,18) = cpl_rriv2D(:,:)
+    
+!*************************************************************************************
+! Transform the fraction of sub-surfaces from 1D to 2D array
+!
+!*************************************************************************************
+    pctsrf2D(:,:,:) = 0.
+    CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
+
+!*************************************************************************************
+! Calculate the average calving per latitude
+! Store calving in tab_flds(:,:,19)
+! 
+!*************************************************************************************      
+    DO j = 1, jj_nb
+       tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
+            pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
+    ENDDO
+    
+    
+    IF (is_parallel) THEN
+       IF (.NOT. is_north_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
+          CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_south_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
+          CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
+          Up=Up+tmp_calv(iim,1)
+          tmp_calv(:,1)=Up
+       ENDIF
+       
+       IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
+          Down=Down+tmp_calv(1,jj_nb)
+          tmp_calv(:,jj_nb)=Down	 
+       ENDIF
+    ENDIF
+      
+
+    tab_flds(:,:,19) = tmp_calv(:,:)
+
+!*************************************************************************************
+! Calculate total flux for snow, rain and wind with weighted addition using the 
+! fractions of ocean and seaice.
+!
+! Store the fields for rain and snow directly in tab_flds(:,:,15) and 
+! tab_flds(:,:,16) respectively.
+!
+!*************************************************************************************    
+    tab_flds(:,:,15) = 0.0
+    tab_flds(:,:,16) = 0.0
+    tmp_taux(:,:)    = 0.0
+    tmp_tauy(:,:)    = 0.0
+    
+
+    ! fraction oce+seaice
+    deno =  pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) 
+    ! For all valid grid cells containing some fraction of ocean or sea-ice
+    WHERE ( deno(:,:) /= 0 )
+       tab_flds(:,:,15) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       tab_flds(:,:,16) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       
+       tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+    ENDWHERE
+
+!*************************************************************************************
+! Transform the wind components from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates. 
+! Store the resulting wind components in tab_flds(:,:,1:6)
+!*************************************************************************************
+
+! Transform the longitudes and latitudes on 2D arrays
+    CALL Grid1DTo2D_mpi(rlon,tmp_lon)
+    CALL Grid1DTo2D_mpi(rlat,tmp_lat)
+    
+    IF (is_sequential) THEN
+       IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
+       IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
+    ENDIF
+      
+! NetCDF output of the wind before transformation of coordinate system
+    IF (is_sequential) THEN
+       ndexct(:) = 0
+       itau_w = itau_phy + itime
+       CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
+    ENDIF
+
+! Transform the wind from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates 
+    CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
+         tab_flds(:,:,1), tab_flds(:,:,2), tab_flds(:,:,3) )
+    
+    tab_flds(:,:,4)  = tab_flds(:,:,1)
+    tab_flds(:,:,5)  = tab_flds(:,:,2)
+    tab_flds(:,:,6)  = tab_flds(:,:,3)
+
+!*************************************************************************************
+! NetCDF output of all fields just before sending to coupler.
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       CALL histwrite(nidct,cl_writ(8), itau_w,tab_flds(:,:,8), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(9), itau_w,tab_flds(:,:,9), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(10),itau_w,tab_flds(:,:,10),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(11),itau_w,tab_flds(:,:,11),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(12),itau_w,tab_flds(:,:,12),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(13),itau_w,tab_flds(:,:,13),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(14),itau_w,tab_flds(:,:,14),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(15),itau_w,tab_flds(:,:,15),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(16),itau_w,tab_flds(:,:,16),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(17),itau_w,tab_flds(:,:,17),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(18),itau_w,tab_flds(:,:,18),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(19),itau_w,tab_flds(:,:,19),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(1), itau_w,tab_flds(:,:,1), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(2), itau_w,tab_flds(:,:,2), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(3), itau_w,tab_flds(:,:,3), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(4), itau_w,tab_flds(:,:,4), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(5), itau_w,tab_flds(:,:,5), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(6), itau_w,tab_flds(:,:,6), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(7), itau_w,tab_flds(:,:,7), iim*(jjm+1),ndexct)
+       CALL histsync(nidct)
+    ENDIF
+
+
+!*************************************************************************************
+! Send the table of all fields
+!
+!*************************************************************************************
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
+#endif
+
+!*************************************************************************************
+! Finish with some dellocate
+!
+!*************************************************************************************  
+    sum_error=0
+    DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, stat=error )
+    sum_error = sum_error + error
+    IF (sum_error /= 0) THEN
+       abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+  END SUBROUTINE cpl_send_all
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! 
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+
+! Input
+    INTEGER, INTENT(IN)                       :: knon
+    REAL, DIMENSION(iim,jj_nb), INTENT(IN)    :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+
+! Output
+    REAL, DIMENSION(klon), INTENT(OUT)        :: champ_out
+
+! Local
+    INTEGER                                   :: i, ig
+    REAL, DIMENSION(klon)                     :: tamp
+
+!*************************************************************************************
+!
+! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
+    CALL Grid2Dto1D_mpi(champ_in,tamp)
+
+! Compress from klon to knon
+    DO i = 1, knon
+       ig = knindex(i)
+       champ_out(i) = tamp(ig)
+    ENDDO
+
+  END SUBROUTINE cpl2gath
+!
+!*************************************************************************************
+!
+  SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                    :: knon
+    REAL, DIMENSION(klon), INTENT(IN)      :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)   :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                :: i, ig
+    REAL, DIMENSION(klon)                  :: tamp
+
+!*************************************************************************************
+
+! Decompress from knon to klon
+    tamp = 0.
+    DO i = 1, knon
+       ig = knindex(i)
+       tamp(ig) = champ_in(i)
+    ENDDO
+
+! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
+    CALL Grid1Dto2D_mpi(tamp,champ_out)
+    
+    IF (is_north_pole) champ_out(:,1)=tamp(1)
+    IF (is_south_pole) champ_out(:,jj_nb)=tamp(klon)
+    
+  END SUBROUTINE gath2cpl
+!
+!*************************************************************************************
+!
+END MODULE cpl_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv3_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv3_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv3_routines.F	(revision 984)
@@ -0,0 +1,3145 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE cv3_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+C   ***                        OF CLOUD                         ***
+C
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+C
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cvparam3.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+c -- "microphysical" parameters:
+
+      sigd   = 0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+cIM cf. FH     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+      dttrig = 5.   ! (loose) condition for triggering 
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau    = 8000.
+      beta   = 1.0 - delt/tau
+      alpha  = 1.5E-3 * delt/tau
+c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end
+
+      SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+
+c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_feed(len,nd,t,q,qs,p,ph,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cvparam3.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+      real A, B ! convect3
+cym
+      plcl=0.0
+c@ !-------------------------------------------------------------------
+c@ ! --- Find level of minimum moist static energy
+c@ ! --- If level of minimum moist static energy coincides with
+c@ ! --- or is lower than minimum allowable parcel origin level,
+c@ ! --- set iflag to 6.
+c@ !-------------------------------------------------------------------
+c@ 
+c@       do 180 i=1,len
+c@        work(i)=1.0e12
+c@        ihmin(i)=nl
+c@  180  continue
+c@       do 200 k=2,nlp
+c@         do 190 i=1,len
+c@          if((hm(i,k).lt.work(i)).and.
+c@      &      (hm(i,k).lt.hm(i,k-1)))then
+c@            work(i)=hm(i,k)
+c@            ihmin(i)=k
+c@          endif
+c@  190    continue
+c@  200  continue
+c@       do 210 i=1,len
+c@         ihmin(i)=min(ihmin(i),nlm)
+c@         if(ihmin(i).le.minorig)then
+c@           iflag(i)=6
+c@         endif
+c@  210  continue
+c@ c
+c@ !-------------------------------------------------------------------
+c@ ! --- Find that model level below the level of minimum moist static
+c@ ! --- energy that has the maximum value of moist static energy
+c@ !-------------------------------------------------------------------
+c@  
+c@       do 220 i=1,len
+c@        work(i)=hm(i,minorig)
+c@        nk(i)=minorig
+c@  220  continue
+c@       do 240 k=minorig+1,nl
+c@         do 230 i=1,len
+c@          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+c@            work(i)=hm(i,k)
+c@            nk(i)=k
+c@          endif
+c@  230     continue
+c@  240  continue
+
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+  220    continue
+
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( t(i,nk(i)).lt.250.0    )
+     &       .or.( q(i,nk(i)).le.0.0      )     )
+c@      &       .or.( p(i,ihmin(i)).lt.400.0 )  )
+     &   .and.
+     &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+c ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+c ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 
+        endif ! iflag=7  
+
+ 260   continue
+
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute1(len,nd,t,q,qs,gz,plcl,p,nk,icb
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len)
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd) 
+      real plcl(len) ! convect3
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+c ori        ticb(i)=t(i,icb(i))
+c ori        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len              
+         ticb(i)=t(i,icb(i)+1)   
+         gzicb(i)=gz(i,icb(i)+1) 
+         qsicb(i)=qs(i,icb(i)+1) 
+        enddo                   
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp
+     o                ,pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cvparam3.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+c
+c   ***   make sure that column is dry adiabatic between the surface  ***
+c   ***    and cloud base, and that lifted air is positively buoyant  ***
+c   ***                         at cloud base                         ***
+c   ***       if not, return to calling program after resetting       ***
+c   ***                        sig(i) and w0(i)                       ***
+c
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = th(i,1)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cvparam3.h"
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd) 
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+c      do 121 j=1,ntra
+c      do 111 k=1,nd
+c       nn=0
+c      do 101 i=1,len
+c      if(iflag1(i).eq.0)then
+c       nn=nn+1
+c       tra(nn,k,j)=tra1(i,k,j)
+c      endif
+c 101  continue
+c 111  continue
+c 121  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c 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)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+c ori          if(k.ge.(nk(i)+1))then
+c ori            tca=tp(i,k)-t0
+c ori            if(tca.ge.0.0)then
+c ori              elacrit=elcrit
+c ori            else
+c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+c ori            endif
+c ori            elacrit=max(elacrit,0.0)
+c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+c ori            ep(i,k)=max(ep(i,k),0.0 )
+c ori            ep(i,k)=min(ep(i,k),1.0 )
+c ori            sigp(i,k)=sigs
+c ori          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c===================================================================== 
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k) 
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+cIM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
+       buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+ 510  continue
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+cym      do i=1,ncum*nlp
+cym       hp(i,1)=h(i,1)
+cym      enddo
+
+      do k=1,nlp
+        do i=1,ncum
+	  hp(i,k)=h(i,k)
+	enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end
+
+      SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb   
+c -------------------------------------------------------
+      
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=amax1(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+      
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),  
+c -- vertical velocity (w), fractional area covered by    
+c -- undilute updraft (sig), and updraft mass flux (m)  
+c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0 
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+
+
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=amax1(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv3_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+! 	- changer rr(il,1) -> qnk(il)
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c 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)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+cym            ment(i,k,j)=0.0
+cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+c      do k=1,ntra
+c       do j=1,nd  ! instead nlp
+c        do i=1,nd ! instead nlp
+c         do il=1,ncum
+c            traent(il,i,j,k)=tra(il,j,k)
+c         enddo
+c        enddo
+c       enddo
+c      enddo
+      zm(:,:)=0.
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il))
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il))
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+c       do k=1,ntra
+c        do j=minorig,nl
+c         do il=1,ncum
+c          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+c     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+c            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c          endif
+c         enddo
+c        enddo
+c       enddo
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then 
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i)
+      uent(il,i,i)=u(il,nk(il))
+      vent(il,i,i)=v(il,nk(il))
+      elij(il,i,i)=clw(il,i)
+cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+ 
+c      do j=1,ntra
+c       do i=minorig+1,nl
+c        do il=1,ncum
+c         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+c          traent(il,i,i,j)=tra(il,nk(il),j)
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+cym      call zilch(asum,ncum*nd)
+cym      call zilch(bsum,ncum*nd)
+cym      call zilch(csum,ncum*nd)
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl 
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=rr(il,1)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=u(il,nk(il))
+        vent(il,i,i)=v(il,nk(il))
+        elij(il,i,i)=clw(il,i)
+cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+c     :     .and. csum(il,i).lt.m(il,i) ) then
+c         traent(il,i,i,j)=tra(il,nk(il),j)
+c        endif
+c       enddo
+c      enddo
+789   continue
+c      
+c MAF: renormalisation de MENT
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+
+      SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl
+     :              ,mp,rp,up,vp,trap,wt,water,evap,b)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real th(nloc,na), gz(nloc,na)
+      real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real cpn(nloc,na), tv(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na)
+
+c local variables
+      integer i,j,k,il,num1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+
+c        do k=1,ntra
+c         do i=1,nd
+c          do il=1,ncum
+c           trap(il,i,k)=tra(il,i,k)
+c          enddo
+c         enddo
+c        enddo
+
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+ 
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+
+c
+c    ***                    begin downdraft loop                    ***
+c
+
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd*wt(il,i))
+c
+cjyg1
+ccc        sigt=1.0
+ccc        if(i.ge.icb)sigt=sigp(i)
+c prise en compte de la variation progressive de sigt dans
+c les couches icb et icb-1:
+c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+c 	pour plcl>ph(i),   pr1=1 & pr2=0
+c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+c    sur le nuage, et pr2 est la proportion sous la base du
+c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+      b6=bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :                -50.*sigd*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)
+     :            +0.02*(wdtrain(il)+sigd*wt(il,i)*water(il,i+1))
+     :                 /(sigd*(ph(il,i)-ph(il,i+1)))
+      end if
+c
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd*tevap
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+      endif
+c
+c    ***           if hydrostatic assumption fails,             ***
+c    ***   solve cubic difference equation for downdraft theta  ***
+c    ***  and mass flux from two simultaneous differential eqns ***
+c
+      amfac=sigd*sigd*70.0*ph(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,i))*xf*tevap
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante: 
+C il faut diviser par (mp(il,i)*sigd*grav) et non par (mp(il,i)+sigd*0.1). 
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+      if(p(il,i).gt.p(il,icb(il)))then
+       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+      endif
+
+360   continue
+      endif ! i.eq.1
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+c      do j=1,ntra
+c      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+ctestmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+c     :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
+c      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+c      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+c       do j=1,ntra
+c       trap(il,i,j)=trap(il,i+1,j)
+c       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end
+
+      SUBROUTINE cv3_yield(nloc,ncum,nd,na,ntra 
+     :                    ,icb,inb,delt
+     :                    ,t,rr,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b
+     :                    ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                    ,tv,tvp
+     :                    ,iflag,precip,VPrecip,ft,fr,fu,fv,ftra
+     :                    ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+cym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mike(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, awat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+
+      do il=1,ncum
+       precip(il)=0.0
+       wd(il)=0.0     ! gust
+       VPrecip(il,nd+1)=0.
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         VPrecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+
+c      do j=1,ntra
+c       do i=1,nd
+c        do il=1,ncum
+c          ftra(il,i,j)=0.0
+c        enddo
+c       enddo 
+c      enddo
+
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum 
+       if(ep(il,inb(il)).ge.0.0001)then 
+        if (cvflag_grav) then
+         precip(il)=wt(il,1)*sigd*water(il,1)*86400.*1000./(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd*water(il,1)*8640.
+        endif
+       endif 
+      enddo 
+
+C   ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
+C
+c MAF rajout pour lessivage
+       do k=1,nl
+         do il=1,ncum
+          if (k.le.inb(il)) then
+            if (cvflag_grav) then
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/grav
+            else
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/10.
+            endif 
+          endif
+         end do
+       end do
+C
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       am(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.le.inb(il)) then
+         am(il)=am(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+      do il=1,ncum
+
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+
+      ft(il,1)=ft(il,1)-0.5*lvcp(il,1)*sigd*(evap(il,1)+evap(il,2))
+
+      if (cvflag_grav) then
+       ft(il,1)=ft(il,1)-0.009*grav*sigd*mp(il,2)
+     :                             *t(il,1)*b(il,1)*work(il)
+      else
+       ft(il,1)=ft(il,1)-0.09*sigd*mp(il,2)*t(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd*wt(il,1)*(cl-cpd)*water(il,2)*(t(il,2)
+     :-t(il,1))*work(il)/cpn(il,1)
+
+      if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+c (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap) 
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+c+tard     :          +sigd*evap(il,1)
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      endif ! cvflag_grav
+
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (cvflag_grav) then
+c         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        else
+c         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        endif
+c       enddo
+c      enddo
+
+      do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il)) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+c      do k=1,ntra
+c       do j=2,nl
+c        do il=1,ncum
+c         if (j.le.inb(il)) then
+
+c          if (cvflag_grav) then
+c           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          else
+c           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          endif
+
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+c
+c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il))num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=i+1,nl+1
+       do 441 il=1,ncum
+        if (i.le.inb(il) .and. k.le.(inb(il)+1)) then
+         amp1(il)=amp1(il)+m(il,k)
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il)) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+      if (cvflag_grav) then
+       ft(il,i)=0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      else  ! cvflag_grav
+       ft(il,i)=0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      endif ! cvflag_grav
+
+
+      ft(il,i)=ft(il,i)+0.01*sigd*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t(il,i+1)-t(il,i))*dpinv*cpinv
+
+      if (cvflag_grav) then
+       fr(il,i)=0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+c      do k=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+c         if (cvflag_grav) then
+c           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         else
+c           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         endif
+c        endif
+c       enddo
+c      enddo
+
+      do 480 k=1,i-1
+       do 1370 il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+      awat=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+      awat=amax1(awat,0.0)
+
+      if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+c      do j=1,ntra
+c       do k=1,i-1
+c        do il=1,ncum
+c         if (i.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 490 k=i,nl+1
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav 
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav 
+        endif ! i and k
+1380   continue
+490   continue
+
+c      do j=1,ntra
+c       do k=i,nl+1
+c        do il=1,ncum
+c         if (i.le.inb(il) .and. k.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :         *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :             *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif ! i and k
+c        enddo
+c       enddo
+c      enddo
+
+      do 1400 il=1,ncum
+       if (i.le.inb(il)) then
+        dpinv=1.0/(ph(il,i)-ph(il,i+1))
+        cpinv=1.0/cpn(il,i)
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+
+         fu(il,i)=fu(il,i)+0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+         fu(il,i)=fu(il,i)+0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+      endif ! i
+1400  continue
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum 
+        if (k.le.inb(il) .and. i.le.inb(il)) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0.) then    ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+
+c         if (cvflag_grav) then
+c          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         else
+c          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         endif
+c        endif ! i
+c       enddo
+c      enddo 
+
+500   continue
+
+
+c   ***   move the detrainment at level inb down to level inb-1   ***
+c   ***        in such a way as to preserve the vertically        ***
+c   ***          integrated enthalpy and water tendencies         ***
+c
+      do 503 il=1,ncum
+
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))
+     : +t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+503   continue
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        ex=0.1*ment(il,inb(il),inb(il)) 
+c     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+c     :      /(ph(il,inb(il))-ph(il,inb(il)+1))
+c        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+c        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+c     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+c     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+c       enddo
+c      enddo
+
+c
+c   ***    homoginize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif 
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+      
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+m(il,k)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!     
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mike(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mike(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        icb represente de niveau ou se trouve la
+c        base du nuage , et inb le top du nuage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 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)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il) ) then                       ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+            
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0)                               ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+cIM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)              ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+        return
+        end
+
+      SUBROUTINE cv3_tracer(nloc,len,ncum,nd,na,
+     &                        ment,sij,da,phi)
+        implicit none
+c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sij(nloc,na,na)
+c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+c local variables:
+        integer i,j,k
+c        
+        da(:,:)=0.
+c
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+            da(i,j)=da(i,j)+(1.-sij(i,k,j))*ment(i,k,j)
+            phi(i,j,k)=sij(i,k,j)*ment(i,k,j)
+c            print *,'da',j,k,da(i,j),sij(i,k,j),ment(i,k,j)
+            end do 
+          end do 
+        end do 
+    
+        return
+        end
+
+
+      SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,VPrecip,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,inb
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,da,phi,mp
+     :         ,iflag1
+     :         ,precip1,VPrecip1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,inb1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :         ,da1,phi1,mp1)
+      implicit none
+
+#include "cvparam3.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      integer inb(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+      real da(nloc,nd),phi(nloc,nd,nd),mp(nloc,nd)
+
+c outputs:
+      integer iflag1(len)
+      integer inb1(len)
+      real precip1(len)
+      real VPrecip1(len,nd+1)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+      real da1(nloc,nd),phi1(nloc,nd,nd),mp1(nloc,nd)
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         inb1(idcum(i))=inb(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            VPrecip1(idcum(i),k)=VPrecip(i,k)
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            da1(idcum(i),k)=da(i,k)
+            mp1(idcum(i),k)=mp(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+c        do 2100 j=1,ntra
+c         do 2110 k=1,nd ! oct3
+c          do 2120 i=1,ncum
+c            ftra1(idcum(i),k,j)=ftra(i,k,j)
+c 2120     continue
+c 2110    continue
+c 2100   continue
+        do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            phi1(idcum(i),k,j)=phi(i,k,j)
+          end do
+         end do
+        end do
+
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv_driver.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv_driver.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv_driver.F	(revision 984)
@@ -0,0 +1,705 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con,
+     &                   t1,q1,qs1,u1,v1,tra1,
+     &                   p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,VPrecip1,
+     &                   cbmf1,sig1,w01,
+     &                   icb1,inb1,
+     &                   delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1,
+     &                   da1,phi1,mp1)
+C
+      USE dimphy
+      implicit none
+C
+C.............................START PROLOGUE............................
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      iflag1        Integer        Output       flag for Emanuel conditions
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      VPrecip1      Real           Output       vertical profile of precipitations
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      delt          Real           Input        time step
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux 
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+C
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3) 
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2) 
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg) 
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      integer iflag_con
+      integer ntra
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real precip1(len)
+      real cbmf1(len)
+      real VPrecip1(len,nd+1)
+      real Ma1(len,nd)
+      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 da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+      real da(len,nd),phi(len,nd,nd),mp(len,nd)
+      real tra1(len,nd,ntra)
+      real ftra1(len,nd,ntra)
+
+      real delt
+
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  VPrecip: Vertical profile of convective precipitation (kg/m2/s).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+
+      integer i,k,n,il,j
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer inb1(klon)
+      integer icbs1(klon)
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev)
+      real cpn1(klon,klev)
+      real tv1(klon,klev)
+      real gz1(klon,klev)
+      real hm1(klon,klev)
+      real h1(klon,klev)
+      real tp1(klon,klev)
+      real tvp1(klon,klev)
+      real clw1(klon,klev)
+      real sig1(klon,klev)
+      real w01(klon,klev)
+      real th1(klon,klev)
+c
+      integer ncum
+c
+c (local) compressed fields:
+c
+cym      integer nloc
+cym      parameter (nloc=klon) ! pour l'instant
+#define nloc klon
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real sij(nloc,klev,klev), elij(nloc,klev,klev)
+      real qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+      real b(nloc,klev), ft(nloc,klev), fq(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+
+      nent(:,:)=0
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters 
+c
+c 	includes microphysical parameters and parameters that 
+c  	control the rate of approach to quasi-equilibrium) 
+c 	(common cvparam)
+
+      if (iflag_con.eq.3) then
+       CALL cv3_param(nd,delt)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft1(i,k)=0.0
+         fq1(i,k)=0.0
+         fu1(i,k)=0.0
+         fv1(i,k)=0.0
+         tvp1(i,k)=0.0
+         tp1(i,k)=0.0
+         clw1(i,k)=0.0
+cym
+         clw(i,k)=0.0	 
+         gz1(i,k) = 0.
+         VPrecip1(i,k) = 0.
+         Ma1(i,k)=0.0
+         upwd1(i,k)=0.0
+         dnwd1(i,k)=0.0
+         dnwd01(i,k)=0.0
+         qcondc1(i,k)=0.0
+ 10     continue
+ 20   continue
+
+      do 30 j=1,ntra
+       do 31 k=1,nd
+        do 32 i=1,len
+         ftra1(i,k,j)=0.0
+ 32     continue    
+ 31    continue    
+ 30   continue    
+
+      do 60 i=1,len
+        precip1(i)=0.0
+        iflag1(i)=0
+        wd1(i)=0.0
+        cape1(i)=0.0
+        VPrecip1(i,nd+1)=0.0
+ 60   continue
+
+      if (iflag_con.eq.3) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1            ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1           ! nd->na
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part 
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content. 
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1  ! nd->na
+     o                        ,tp1,tvp1,clw1,icbs1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+
+c       print*,'klon, ncum = ',len,ncum
+
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+       CALL cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+
+!-------------------------------------------------------------------
+! --- MIXING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                     ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,m,sig
+     o ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb    ! na->nd
+     :               ,t,q,qs,gz,u,v,tra,p,ph
+     :               ,th,tv,lv,cpn,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl
+     o          ,mp,qp,up,vp,trap,wt,water,evap,b)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b
+     :                     ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                     ,tv,tvp
+     o                     ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra
+     o                     ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+       CALL cv3_tracer(nloc,len,ncum,nd,nd,
+     :                  ment,sij,da,phi)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+c set iflag1 =42 for non convective points 
+      do  i=1,len
+        iflag1(i)=42
+      end do
+c
+      if (iflag_con.eq.3) then
+       CALL cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag
+     :          ,precip,VPrecip,sig,w0
+     :          ,ft,fq,fu,fv,ftra
+     :          ,inb 
+     :          ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :          ,da,phi,mp
+     o          ,iflag1
+     o          ,precip1,VPrecip1,sig1,w01
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,inb1
+     o          ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 
+     o          ,da1,phi1,mp1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc            
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )           
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_flag
+      implicit none
+
+#include "cvflag.h"
+
+c -- si .TRUE., on rend la gravite plus explicite et eventuellement
+c differente de 10.0 dans convect3: 
+      cvflag_grav = .TRUE.
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_thermo(iflag_con)
+	  implicit none
+
+c-------------------------------------------------------------
+c Set thermodynamical constants for convectL
+c-------------------------------------------------------------
+
+#include "YOMCST.h" 
+#include "cvthermo.h" 
+
+      integer iflag_con
+
+
+c original set from convect:
+      if (iflag_con.eq.4) then
+       cpd=1005.7
+       cpv=1870.0
+       cl=4190.0
+       rrv=461.5
+       rrd=287.04
+       lv0=2.501E6
+       g=9.8
+       t0=273.15
+       grav=g
+      endif
+
+c constants consistent with LMDZ:
+      if (iflag_con.eq.3) then
+       cpd = RCPD
+       cpv = RCPV
+       cl  = RCW
+       rrv = RV
+       rrd = RD
+       lv0 = RLVTT
+       g   = RG     ! not used in convect3
+c ori      t0  = RTT
+       t0  = 273.15 ! convect3 (RTT=273.16)
+c maf       grav= 10.    ! implicitely or explicitely used in convect3
+       grav= g    ! implicitely or explicitely used in convect3
+      endif
+
+      rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?)
+
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      cpvmcl=cl-cpv ! for convect3
+      eps=rrd/rrv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c      ginv=1.0/g
+      ginv=1.0/grav
+      hrd=0.5*rrd
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cv_routines.F	(revision 984)
@@ -0,0 +1,1755 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_param(nd)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL
+c (includes microphysical parameters and parameters that 
+c  control the rate of approach to quasi-equilibrium) 
+c------------------------------------------------------------
+
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+#include "cvparam.h"
+      integer nd
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+      noff = 2
+      minorig = 2
+
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      elcrit=0.0011
+      tlcrit=-55.0
+      entp=1.5
+      sigs=0.12
+      sigd=0.05
+      omtrain=50.0
+      omtsnow=5.5
+      coeffr=1.0
+      coeffs=0.8
+      dtmax=0.9
+c
+      cu=0.70
+c
+      betad=10.0
+c
+      damp=0.1
+      alpha=0.2
+c
+      delta=0.01  ! cld
+c
+      return
+      end
+
+      SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+
+c local variables:
+      integer k, i
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+
+      do 110 k=1,nlp
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C================================================================
+
+#include "cvparam.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax
+     :                       ,tp,tvp,clw)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len), icbmax
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd)
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-t0)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+      return
+      end
+
+      SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+#include "cvparam.h"
+
+c inputs:
+       integer len, nd, icb(len)
+       real cbmf(len), tv(len,nd), tvp(len,nd)
+
+c outputs:
+       integer iflag(len) ! also an input
+
+c local variables:
+       integer i
+
+
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+      return
+      end
+
+      SUBROUTINE cv_compress( len,nloc,ncum,nd
+     :   ,iflag1,nk1,icb1
+     :   ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :   ,t1,q1,qs1,u1,v1,gz1
+     :   ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o   ,iflag,nk,icb
+     o   ,cbmf,plcl,tnk,qnk,gznk
+     o   ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o   ,dph          )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len,ncum,nd,nloc
+      integer iflag1(len),nk1(len),icb1(len)
+      real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+
+c outputs:
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real dph(nloc,nd)
+
+c local variables:
+      integer i,k,nn
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      cbmf(nn)=cbmf1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      do 170 k=1,nl
+       do 160 i=1,ncum
+        dph(i,k)=ph(i,k)-ph(i,k+1)
+ 160   continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,dph,h,tv,lv
+     o                       ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd), dph(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+
+c outputs:
+      integer inb(nloc), inb1(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real frac(nloc)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=sigs
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-t0)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-t0)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-t0
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+c initialization:
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+        return
+        end
+c
+      SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb
+     :                     ,tv,tvp,p,ph,dph,plcl,cpn
+     :                     ,iflag,cbmf)
+      implicit none
+
+c inputs:
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc)
+      real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd)
+      real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent...
+      real plcl(nloc), cpn(nloc,nd)
+
+c outputs:
+      integer iflag(nloc)
+      real cbmf(nloc) ! also an input
+
+c local variables:
+      integer i, k, icbmax
+      real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+      real work(nloc)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c-------------------------------------------------------------------
+c Compute icbmax. 
+c-------------------------------------------------------------------
+
+      icbmax=2
+      do 230 i=1,ncum
+       icbmax=max(icbmax,icb(i))
+ 230  continue
+
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX 
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+
+       return
+       end
+
+      SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1
+     :                    ,ph,t,q,qs,u,v,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,cbmf
+     :                    ,m,ment,qent,uent,vent,nent,sij,elij)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+      real cbmf(nloc), qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd)
+      real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd)
+      real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd)
+
+c outputs:
+      integer nent(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real sij(nloc,nd,nd), elij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, ij
+      integer num1, num2
+      real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+      real alt, qp1, smid, sjmin, sjmax, delp, delm
+      real work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+      real bsum(nloc,nd)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          m(i,1)=0.0
+ 360    continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rrv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+       return
+       end
+
+      SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                  ,h,lv,ep,sigp,clw,m,ment,elij
+     :                  ,iflag,mp,qp,up,vp,wt,water,evap)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer inb(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd)
+      real gz(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd)
+
+c outputs:
+      integer iflag(nloc) ! also an input
+      real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+      real water(nloc,nd), evap(nloc,nd), wt(nloc,nd)
+
+c local variables:
+      integer i,j,k,ij,num1
+      integer jtt(nloc)
+      real awat, coeff, qsm, afac, sigt, b6, c6, revap
+      real dhdp, fac, qstm, rat
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c Initializations:
+c
+         do i = 1, ncum
+         do k = 1, nl+1
+          wt(i,k) = omtsnow
+          mp(i,k) = 0.0
+          evap(i,k) = 0.0
+          water(i,k) = 0.0
+         enddo
+         enddo
+
+         do 420 i=1,ncum
+          qp(i,1)=q(i,1)
+          up(i,1)=u(i,1)
+          vp(i,1)=v(i,1)
+ 420     continue
+
+         do 440 k=2,nl+1
+         do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430     continue
+ 440     continue
+
+
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+        return
+        end
+
+      SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :             ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :             ,ep,clw,frac,m,mp,qp,up,vp
+     :             ,wt,water,evap
+     :             ,ment,qent,uent,vent,nent,elij
+     :             ,tv,tvp
+     o             ,iflag,wd,qprime,tprime
+     o             ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc), inb(nloc)
+      integer nent(nloc,nd)
+      real delt
+      real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real gz(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real hp(nloc,nd), lv(nloc,nd)
+      real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc)
+      real m(nloc,nd), mp(nloc,nd), qp(nloc,nd)
+      real up(nloc,nd), vp(nloc,nd)
+      real wt(nloc,nd), water(nloc,nd), evap(nloc,nd)
+      real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c outputs
+      integer iflag(nloc)  ! also an input
+      real cbmf(nloc)      ! also an input
+      real wd(nloc), tprime(nloc), qprime(nloc)
+      real precip(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd)
+
+c local variables
+      integer i,j,ij,k,num1
+      real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti
+      real work(nloc), am(nloc),amp1(nloc),ad(nloc)
+      real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld
+      real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd)     ! cld
+
+ 
+c -- initializations:
+
+      delti = 1.0/delt
+
+      do 160 i=1,ncum
+      precip(i)=0.0
+      wd(i)=0.0
+      tprime(i)=0.0
+      qprime(i)=0.0
+       do 170 k=1,nl+1
+        ft(i,k)=0.0
+        fu(i,k)=0.0
+        fv(i,k)=0.0
+        fq(i,k)=0.0
+        lvcp(i,k)=lv(i,k)/cpn(i,k)
+        qcondc(i,k)=0.0              ! cld
+        qcond(i,k)=0.0               ! cld
+        nqcond(i,k)=0.0              ! cld
+ 170   continue
+ 160  continue
+
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+      do i=1,ncum
+       wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i))
+     :           /(sigd*p(i,icb(i)))
+       qprime(i)=0.5*(qp(i,1)-q(i,1))
+       tprime(i)=lv0*qprime(i)/cpd
+      enddo
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+c (saturated updrafts resulting from mixing)               ! cld
+               qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld
+               nqcond(ij,i)=nqcond(ij,i)+1.                ! cld
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+C (saturated downdrafts resulting from mixing)               ! cld
+            do k=i+1,inb(ij)                                 ! cld
+             qcond(ij,i)=qcond(ij,i)+elij(ij,k,i)            ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            enddo                                            ! cld
+C (particular case: no detraining level is found)            ! cld
+            if (nent(ij,i).eq.0) then                        ! cld
+             qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            endif                                            ! cld
+            if (nqcond(ij,i).ne.0.) then                     ! cld
+             qcond(ij,i)=qcond(ij,i)/nqcond(ij,i)            ! cld
+            endif                                            ! cld
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+             qcondc(i,k)=0.0                               ! cld
+           endif
+ 1910    continue
+ 1920   continue
+
+        do k=1,nl+1
+        do i=1,ncum
+          Ma(i,k) = 0.
+        enddo
+        enddo
+        do k=nl,1,-1
+        do i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        enddo
+        enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+      DO ij=1,ncum                                          ! cld   
+       do i=1,nd                                            ! cld 
+        mac(ij,i)=0.0                                       ! cld   
+        wa(ij,i)=0.0                                        ! cld
+        siga(ij,i)=0.0                                      ! cld
+       enddo                                                ! cld
+       do i=nk(ij),inb(ij)                                  ! cld
+       do k=i+1,inb(ij)+1                                   ! cld
+        mac(ij,i)=mac(ij,i)+m(ij,k)                         ! cld
+       enddo                                                ! cld
+       enddo                                                ! cld
+       do i=icb(ij),inb(ij)-1                               ! cld
+        ax(ij,i)=0.                                         ! cld
+        do j=icb(ij),i                                      ! cld
+         ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j))         ! cld   
+     :       *(ph(ij,j)-ph(ij,j+1))/p(ij,j)                 ! cld   
+        enddo                                               ! cld
+        if (ax(ij,i).gt.0.0) then                           ! cld   
+         wa(ij,i)=sqrt(2.*ax(ij,i))                         ! cld
+        endif                                               ! cld
+       enddo                                                ! cld
+       do i=1,nl                                            ! cld
+        if (wa(ij,i).gt.0.0)                                ! cld
+     :    siga(ij,i)=mac(ij,i)/wa(ij,i)                     ! cld   
+     :        *rrd*tvp(ij,i)/p(ij,i)/100./delta             ! cld   
+        siga(ij,i) = min(siga(ij,i),1.0)                    ! cld
+        qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i))     ! cld   
+     :          + (1.-siga(ij,i))*qcond(ij,i)               ! cld   
+       enddo                                                ! cld
+      ENDDO                                                 ! cld   
+
+        return
+        end
+
+      SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum
+     :         ,iflag
+     :         ,precip,cbmf
+     :         ,ft,fq,fu,fv
+     :         ,Ma,qcondc            
+     :         ,iflag1
+     :         ,precip1,cbmf1
+     :         ,ft1,fq1,fu1,fv1
+     :         ,Ma1,qcondc1            
+     :                               )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len, ncum, nd, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc), cbmf(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd) !cld
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len), cbmf1(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real Ma1(len,nd)
+      real qcondc1(len,nd) !cld
+
+c local variables:
+      integer i,k
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvflag.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvflag.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvflag.h	(revision 984)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      logical cvflag_grav
+
+      COMMON /cvflag/ cvflag_grav 
+c$OMP THREADPRIVATE(/cvflag/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvltr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvltr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvltr.F	(revision 984)
@@ -0,0 +1,145 @@
+c
+c $Header$
+c
+      SUBROUTINE cvltr(pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx)
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : convection des traceurs / KE
+c Auteurs: M-A Filiberti and J-Y Grandpeix
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+      REAL paprs(klon,klev+1) ! pression aux 1/2 couches (bas en haut)
+      REAL pplay(klon,klev)  ! pression pour le milieu de chaque couche
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+      REAL upd(klon,klev)      ! saturated updraft mass flux
+      REAL dnd(klon,klev)      ! saturated downdraft mass flux
+c
+c--variables locales      
+      real zed(klon,klev),zmd(klon,klev,klev)
+      real za(klon,klev,klev)
+      real zmfd(klon,klev),zmfa(klon,klev)
+      real zmfp(klon,klev),zmfu(klon,klev)
+      integer i,k,j 
+c test conservation
+c      real conserv
+c =========================================
+c calcul des tendances liees au downdraft
+c =========================================
+      zed(:,:)=0.
+      zmfd(:,:)=0.
+      zmfa(:,:)=0.
+      zmfu(:,:)=0.
+      zmfp(:,:)=0.
+      zmd(:,:,:)=0.
+      za(:,:,:)=0.
+c entrainement
+      do k=1,klev-1
+        do i=1,klon
+          zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
+        end do
+      end do
+c
+c calcul de la matrice d echange
+c matrice de distribution de la masse entrainee en k
+c
+      do k=1,klev
+        do i=1,klon
+          zmd(i,k,k)=zed(i,k)
+        end do
+      end do
+      do k=2,klev
+        do j=k-1,1,-1
+          do i=1,klon
+          if(mp(i,j+1).ne.0) then
+          zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
+          endif
+          end do
+        end do
+      end do
+      do k=1,klev
+        do j=1,klev-1
+          do i=1,klon
+          za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+          end do
+        end do
+      end do
+c
+c rajout du terme lie a l ascendance induite
+c
+        do j=2,klev
+         do i=1,klon
+          za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+         end do
+        end do
+C
+c tendances
+c            
+      do k=1,klev
+        do j=1,klev
+          do i=1,klon
+          zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k)-x(i,j))
+          end do
+        end do
+      end do
+c
+c =========================================
+c calcul des tendances liees aux flux satures
+c =========================================
+      do j=1,klev
+        do i=1,klon
+          zmfa(i,j)=da(i,j)*(x(i,1)-x(i,j))
+        end do
+      end do
+      do k=1,klev
+        do j=1,klev
+          do i=1,klon
+          zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k)-x(i,j))
+          end do
+        end do
+      end do
+      do j=1,klev-1
+        do i=1,klon
+          zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1)-x(i,j))
+        end do
+      end do
+      do j=2,klev
+        do i=1,klon
+          zmfu(i,j)=zmfu(i,j)
+     .             +min(0.,upd(i,j)+dnd(i,j))*(x(i,j)-x(i,j-1))
+        end do
+      end do
+
+c =========================================
+c--calcul final des tendances
+c =========================================
+      do k=1, klev
+        do i=1, klon
+          dx(i,k)=(zmfd(i,k)+zmfu(i,k)
+     .      +zmfa(i,k)+zmfp(i,k))*pdtime
+     .      *RG/(paprs(i,k)-paprs(i,k+1))
+c          print*,'dx',k,dx(i,k)
+        enddo
+      enddo
+c
+c test de conservation du traceur
+c      conserv=0.
+c      do k=1, klev
+c        do i=1, klon
+c         conserv=conserv+dx(i,k)*
+c     .     (paprs(i,k)-paprs(i,k+1))/RG
+C
+c        enddo
+c      enddo
+c      print *,'conserv',conserv
+     
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvparam.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvparam.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvparam.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+c------------------------------------------------------------
+c Parameters for convectL:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real elcrit, tlcrit
+      real entp
+      real sigs, sigd
+      real omtrain, omtsnow, coeffr, coeffs
+      real dtmax
+      real cu
+      real betad
+      real alpha, damp
+      real delta
+
+      COMMON /cvparam/ noff, minorig, nl, nlp, nlm
+     :                ,elcrit, tlcrit
+     :                ,entp, sigs, sigd
+     :                ,omtrain, omtsnow, coeffr, coeffs
+     :                ,dtmax, cu, betad, alpha, damp, delta
+
+c$OMP THREADPRIVATE(/cvparam/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvparam3.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvparam3.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvparam3.h	(revision 984)
@@ -0,0 +1,30 @@
+!
+! $Header$
+!
+c------------------------------------------------------------
+c Parameters for convectL, iflag_con=3:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigd, spfac
+cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE   real pbcrit, ptcrit, epmax
+      real pbcrit, ptcrit
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha
+      real delta
+      real betad
+
+      COMMON /cvparam3/  noff, minorig, nl, nlp, nlm
+     :                ,  sigd, spfac
+cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE  :                ,pbcrit, ptcrit, epmax
+     :                ,pbcrit, ptcrit
+     :                ,omtrain
+     :                ,dtovsh, dpbase, dttrig
+     :                ,dtcrit, tau, beta, alpha, delta, betad
+
+c$OMP THREADPRIVATE(/cvparam3/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvthermo.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvthermo.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/cvthermo.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c Thermodynamical constants for convectL:
+
+      real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+      real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl
+      real eps, epsi, epsim1
+      real ginv, hrd
+      real grav
+
+      COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+     :                 ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl 
+     :                 ,eps, epsi, epsim1, ginv, hrd, grav
+
+c$OMP THREADPRIVATE(/cvthermo/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/diagphy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/diagphy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/diagphy.F	(revision 984)
@@ -0,0 +1,411 @@
+!
+! $Header$
+!
+      SUBROUTINE diagphy(airephy,tit,iprt
+     $    , tops, topl, sols, soll, sens
+     $    , evap, rain_fall, snow_fall, ts
+     $    , d_etp_tot, d_qt_tot, d_ec_tot
+     $    , fs_bound, fq_bound)
+C======================================================================
+C
+C Purpose:
+C    Compute the thermal flux and the watter mass flux at the atmosphere
+c    boundaries. Print them and also the atmospheric enthalpy change and
+C    the  atmospheric mass change.
+C
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+C                   (i.e. -1 * flux absorbed by the surface)
+C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+C                   (i.e. flux emited - flux absorbed by the surface)
+C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+C                   (kg/m2/s), positive up
+C rain_fall(klon)
+C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+C snow_fall(klon)
+C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+C ts(klon)----input-R- Surface temperature (K)
+C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+C                    change (W/m2)
+C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+C                    change (kg/m2/s)
+C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+C                    change (W/m2)
+C
+C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+C
+C J.L. Dufresne, July 2002
+C======================================================================
+C 
+      implicit none
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+c     Output variables
+      REAL fs_bound, fq_bound
+C
+C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+C
+      integer i
+C
+      integer pas
+      save pas
+      data pas/0/
+c$OMP THREADPRIVATE(pas)
+C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+C
+C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+C     la glace, on travaille par difference a la chaleur specifique de l'
+c     air sec. En effet, comme on travaille a niveau de pression donne,
+C     toute variation de la masse d'un constituant est totalement
+c     compense par une variation de masse d'air.
+C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront
+     $         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice
+     $           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront
+     $    + slat
+C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+C
+      IF (iprt.ge.1) write(6,6666) 
+     $    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+C
+      IF (iprt.ge.1) write(6,6668) 
+     $    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+C
+      IF (iprt.ge.2) write(6,6667) 
+     $    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot
+     $    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end
+
+C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime
+     e  ,t,q,ql,qs,u,v,paprs,pplay
+     s  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la physique. Suppose que les niveau de
+c    pression entre couche ne varie pas entre 2 appels.
+C
+C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+c bilans sont sauvegardes dans des tableaux indices. On parlera
+C "d'indice de diagnostic"
+c 
+C
+c======================================================================
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c qs-------input-R- solid watter (kg/kg)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c paprs----input-R- pression a intercouche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C     other (COMMON...)
+C     RCPD, RCPV, ....
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+c$OMP THREADPRIVATE(pas)
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+c$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+c$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+c======================================================================
+C
+      DO k = 1, klev
+        DO i = 1, klon
+C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+C
+C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i) 
+     $        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*ql(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*qs(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+      RETURN 
+      END 
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimphy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimphy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimphy.F90	(revision 984)
@@ -0,0 +1,43 @@
+MODULE dimphy
+  
+  INTEGER,SAVE :: klon
+  INTEGER,SAVE :: kdlon
+  INTEGER,SAVE :: kfdia
+  INTEGER,SAVE :: kidia
+  INTEGER,SAVE :: nbtr 
+  INTEGER,SAVE :: klev
+  INTEGER,SAVE :: klevp1
+  INTEGER,SAVE :: klevm1
+  INTEGER,SAVE :: kflev
+
+!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
+  REAL,save,allocatable,dimension(:) :: zmasq
+!$OMP THREADPRIVATE(zmasq)   
+
+CONTAINS
+  
+  SUBROUTINE Init_dimphy(klon0,klev0,nbtr0)
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    INTEGER, INTENT(in) :: nbtr0
+    
+    klon=klon0
+    
+    kdlon=klon
+    kidia=1
+    kfdia=klon
+!$OMP MASTER 
+    klev=klev0
+    nbtr=nbtr0
+    klevp1=klev+1
+    klevm1=klev-1
+    kflev=klev
+!$OMP END MASTER    
+    ALLOCATE(zmasq(klon))    
+    
+  END SUBROUTINE Init_dimphy
+
+  
+END MODULE dimphy
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimphy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimphy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimphy.h	(revision 984)
@@ -0,0 +1,13 @@
+!
+! $Header$
+!
+c-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2-1/jjm,
+     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
+c-----------------------------------------------------------------------
+      INTEGER nbtr ! nombre de vrais traceurs
+      PARAMETER (nbtr=nqmx-2+1/(nqmx-1))
+c-----------------------------------------------------------------------
+      REAL zmasq(KLON)
+      COMMON/terreoce/zmasq
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimsoil.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimsoil.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/dimsoil.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER nsoilmx
+      PARAMETER (nsoilmx=11)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ecribin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ecribin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ecribin.F	(revision 984)
@@ -0,0 +1,102 @@
+!
+! $Header$
+!
+      SUBROUTINE ecribins(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim +1,jjm+1)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim +1
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+            zz(iim+1,j)=zz(1,j)
+         ENDDO
+c-----------------------------------------------------------------------
+#ifdef VPP
+      CALL ecriture(unit,zz,(iim+1)*(jjm+1))
+#else
+      WRITE(unit) zz
+#endif
+c
+
+      RETURN
+      END
+      SUBROUTINE ecribina(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim+1,jjm+1,llm)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim +1
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+            zz(iim+1,j,ilay)=zz(1,j,ilay)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+#ifdef VPP
+         CALL ecriture(unit, zz(1,1,ilay), (iim+1)*(jjm+1))
+#else
+         WRITE(unit) ((zz(i,j,ilay),i=1,iim +1),j=1,jjm+1)
+#endif
+      ENDDO
+c
+      RETURN
+      END
+#ifdef VPP
+@OPTIONS NODOUBLE
+      SUBROUTINE ecriture(nunit, r8, n)
+      INTEGER nunit, n, i
+      REAL*8 r8(n)
+      REAL*4 r4(n)
+      DO i = 1, n
+         r4(i) = r8(i)
+      ENDDO
+      WRITE(nunit)r4
+      RETURN
+      END
+#endif
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ecrireg.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ecrireg.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ecrireg.F	(revision 984)
@@ -0,0 +1,119 @@
+!
+! $Header$
+!
+      SUBROUTINE ecriregs(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim,jjm+1)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+         ENDDO
+c-----------------------------------------------------------------------
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      RETURN
+      END
+      SUBROUTINE ecrirega(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim,jjm+1,llm)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp.F	(revision 984)
@@ -0,0 +1,542 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,ratqs,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl, rhcl)
+
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+#include "fisrtilp.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rhcl(klon,klev) ! humidite relative en ciel clair
+      REAL rain(klon) ! pluies (mm/s)
+      REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+cAA
+c Coeffients de fraction lessivee : pour OFF-LINE
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+      real zct(klon),zcl(klon)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+
+      INTEGER ninter ! sous-intervals pour la precipitation
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur
+
+      real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
+      real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon)
+      real erf
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c$OMP THREADPRIVATE(a_tr_sca)
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+      REAL zmair, zcpair, zcpeau
+C     Pour la conversion eau-neige
+      REAL zlh_solid(klon), zm_solid
+cIM 
+cym      INTEGER klevm1
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
+      fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
+c
+      DATA appel1er /.TRUE./
+cym
+      zdelq=0.0
+      
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+c         CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c  nexpo regle la raideur de la transition eau liquide / eau glace.
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+cIM : klevm1
+cym      klevm1=klev-1
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer la varition de temp. de l'air du a la chaleur sensible
+C transporter par la pluie.
+C Il resterait a rajouter cet effet de la chaleur sensible sur les
+C flux de surface, du a la diff. de temp. entre le 1er niveau et la
+C surface.
+C
+      DO i = 1, klon
+cIM
+       IF(k.LE.klevm1) THEN         
+        zmair=(paprs(i,k)-paprs(i,k+1))/RG
+        zcpair=RCPD*(1.0+RVTMP2*zq(i))
+        zcpeau=RCPD*RVTMP2
+        zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau
+     $      + zmair*zcpair*zt(i) )
+     $      / (zmair*zcpair + zrfl(i)*dtime*zcpeau)
+CC        WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1))
+       ENDIF
+      ENDDO
+c
+c
+c Calculer l'evaporation de la precipitation
+c
+
+
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+
+c pour la glace, on r�vapore toute la pr�ip dans la couche du dessous
+c la glace venant de la couche du dessus est simplement dans la couche
+c du dessous.
+
+         IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
+
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+
+c        print*,'Dans partiel k=',k
+c
+c   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
+c   nuageuse a partir des PDF de Sandrine Bony.
+c   rneb  : fraction nuageuse
+c   zqn   : eau totale dans le nuage
+c   zcond : eau condensee moyenne dans la maille.
+c           on prend en compte le r�hauffement qui diminue la partie condensee
+c
+c   Version avec les raqts
+
+         if (iflag_pdf.eq.0) then
+
+           do i=1,klon
+            zdelq = min(ratqs(i,k),0.99) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+           enddo
+
+         else
+c
+c   Version avec les nouvelles PDFs.
+           do i=1,klon
+              if(zq(i).lt.1.e-15) then
+                print*,'ZQ(',i,',',k,')=',zq(i)
+                zq(i)=1.e-15
+              endif
+           enddo
+           do i=1,klon
+            zpdf_sig(i)=ratqs(i,k)*zq(i)
+            zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+            zpdf_delta(i)=log(zq(i)/zqs(i))
+            zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+            zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+            zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+            zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
+            zpdf_e1(i)=1.-erf(zpdf_e1(i))
+            zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+            zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
+            zpdf_e2(i)=1.-erf(zpdf_e2(i))
+            if (zpdf_e1(i).lt.1.e-10) then
+               rneb(i,k)=0.
+               zqn(i)=zqs(i)
+            else
+               rneb(i,k)=0.5*zpdf_e1(i)
+               zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+            endif
+            
+           enddo
+
+        endif ! iflag_pdf
+
+         do i=1,klon
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+c           zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+c  On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par
+c  la convection.
+c  ATTENTION !!! Il va falloir verifier tout ca.
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+c           print*,'ZDQS ',zdqs(i)
+c--Olivier
+            rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0
+c--fin
+           ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+c         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+
+         if (ptconv(i,k)) then
+            zcl(i)=cld_lc_con
+            zct(i)=1./cld_tau_con
+         else
+            zcl(i)=cld_lc_lsc
+            zct(i)=1./cld_tau_lsc
+         endif
+c  quantit�d'eau ��minier.
+         zchau(i) = zct(i)*dtime/FLOAT(ninter) * zoliq(i)
+     .         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl(i))**2)) *(1.-zfice(i))
+c  meme chose pour la glace.
+         if (ptconv(i,k)) then
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvc(zrhol(i)) * zfice(i)
+         else
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvs(zrhol(i)) * zfice(i)
+         endif
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+      ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
+      ENDDO
+c
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
+cAA Lessivage par impaction dans les couches en-dessous
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
+c
+cAA----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+         zlh_solid(i) = RLSTT-RLVTT
+      ELSE
+         rain(i) = zrfl(i)
+         zlh_solid(i) = 0.
+      ENDIF
+      ENDDO
+C
+C For energy conservation : when snow is present, the solification
+c latent heat is considered.
+      DO k = 1, klev
+        DO i = 1, klon
+          zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
+          zmair=(paprs(i,k)-paprs(i,k+1))/RG
+          zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
+          d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair)
+        END DO 
+      END DO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp.h	(revision 984)
@@ -0,0 +1,28 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+      REAL cld_lc_lsc,cld_lc_con
+      REAL cld_tau_lsc,cld_tau_con
+      REAL ffallv_lsc,ffallv_con
+      REAL coef_eva
+      LOGICAL reevap_ice
+      INTEGER iflag_pdf
+
+      common/comfisrtilp/                                               &
+     &     cld_lc_lsc                                                   &
+     &     ,cld_lc_con                                                  &
+     &     ,cld_tau_lsc                                                 &
+     &     ,cld_tau_con                                                 &
+     &     ,ffallv_lsc                                                  &
+     &     ,ffallv_con                                                  &
+     &     ,coef_eva                                                    &
+     &     ,reevap_ice                                                  &
+     &     ,iflag_pdf        
+
+!$OMP THREADPRIVATE(/comfisrtilp/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp_tr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp_tr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fisrtilp_tr.F	(revision 984)
@@ -0,0 +1,435 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,ratqs,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl,
+     s                   RHcl) ! relative humidity in clear sky (needed for aer optical properties; aeropt.F)
+
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rain(klon) ! pluies (mm/s)
+      REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      
+Cjq   For aerosol opt properties needed (see aeropt.F)
+      REAL RHcl(klon,klev)
+      
+cAA
+c Coeffients de fraction lessivee : pour OFF-LINE
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+      REAL ct ! inverse du temps pour qu'un nuage precipite
+      PARAMETER (ct=1./1800.)
+      REAL cl ! seuil de precipitation
+      PARAMETER (cl=2.6e-4)
+ccc      PARAMETER (cl=2.3e-4)
+ccc      PARAMETER (cl=2.0e-4)
+      INTEGER ninter ! sous-intervals pour la precipitation
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=2.0E-05)
+      LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      PARAMETER (calcrat=.TRUE.)
+      REAL zx_min, rat_max
+      PARAMETER (zx_min=1.0, rat_max=0.01)
+      REAL zx_max, rat_min
+      PARAMETER (zx_max=0.1, rat_min=0.3)
+      REAL zx
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c$OMP THREADPRIVATE(a_tr_sca)
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallv ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallv (zzz) = 3.29/2.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29 * ((zzz)**0.16)
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, calcrat:', calcrat
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+          CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer l'evaporation de la precipitation
+c
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+         DO i = 1, klon
+c
+            zdelq = ratqs(i,k) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+            
+c--Olivier
+            RHcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) RHcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) RHcl(i,k)=1.0
+c--fin
+            
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zchau(i) = ct*dtime/FLOAT(ninter) * zoliq(i)
+     .          * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i))
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+         zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallv(zrhol(i)) * zfice(i)
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+      ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
+      ENDDO
+c
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
+cAA Lessivage par impaction dans les couches en-dessous
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
+c
+cAA----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+      ELSE
+         rain(i) = zrfl(i)
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/flxtr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/flxtr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/flxtr.F	(revision 984)
@@ -0,0 +1,207 @@
+!
+! $Header$
+!
+      SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) 
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux, kcbot, kctop et kdtop
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --Un schema amont est choisi pour calculer les flux pour s'assurer 
+c   de la positivite des valeurs de traceurs, cela implique des eqs 
+c   differentes pour les flux de traceurs montants et descendants.
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant 
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+c--idem mais en variables locales
+      REAL zpen_u(klon,klev) 
+      REAL zpde_u(klon,klev)
+      REAL zpen_d(klon,klev) 
+      REAL zpde_d(klon,klev)
+c
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL pap(klon,klev)      ! pression aux couches (haut en bas)
+      REAL pt(klon,klev)       ! temperature aux couches (bas en haut) 
+      REAL zt(klon,klev)       ! temperature aux couches (haut en bas)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL paph(klon,klev+1)   ! pression aux 1/2 couches (haut en bas)
+      INTEGER kcbot(klon)      ! niveau de base de la convection
+      INTEGER kctop(klon)      ! niveau du sommet de la convection +1 
+      INTEGER kdtop(klon)      ! niveau de sommet du panache descendant
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL zx(klon,klev)       ! q de traceur (haut en bas)
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL xe(klon,klev)        ! q de traceurs dans l'environnement 
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+c
+c On remet les taux d'entrainement et de detrainement dans le panache
+c descendant a des valeurs positives. 
+c On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la 
+c conservation de la masse soit realisee a chaque niveau dans les 2 
+c panaches.
+      DO k=1, klev
+      DO i=1, klon
+        zpen_u(i,k)= pen_u(i,k)
+        zpde_u(i,k)= pde_u(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO k=1, klev-1
+      DO i=1, klon
+        zpen_d(i,k)=-pen_d(i,k+1)
+        zpde_d(i,k)=-pde_d(i,k+1)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon 
+      zpen_d(i,klev)       = 0.0
+      zpde_d(i,klev)       = -pmfd(i,klev)
+c   Correction 03 11 97
+c     zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      IF (kdtop(i).EQ.klev+1) THEN
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)
+      ELSE
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      ENDIF
+
+      zpde_u(i,kctop(i)-2) = pmfu(i,kctop(i)-1)
+      zpen_u(i,klev)       = pmfu(i,klev) 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=kcbot(i), klev-1
+      zpen_u(i,k) = pmfu(i,k) - pmfu(i,k+1)
+      ENDDO 
+      ENDDO 
+c
+c conversion des sens de notations bas-haut et haut-bas
+c
+      DO k=1, klev+1 
+      DO i=1, klon 
+        paph(i,klev+2-k)=paprs(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=1, klev 
+        pap(i,klev+1-k)=pplay(i,k)
+        zt(i,klev+1-k) =pt(i,k)
+        zx(i,klev+1-k) =x(i,k) 
+      ENDDO 
+      ENDDO
+c
+c--initialisations des flux de traceurs aux extremites de la colonne
+c
+      DO i=1, klon 
+        zmfux(i,klev+1) = 0.0 
+        zmfdx(i,1) = 0.0 
+        zmfex(i,1) = 0.0 
+      ENDDO
+c
+c--calcul des flux dans le panache montant
+c
+      DO k=klev, 1, -1
+      DO i=1, klon
+       IF (k.GE.kcbot(i)) THEN 
+         xu(i,k)=zx(i,k)
+         zmfux(i,k)=pmfu(i,k)*xu(i,k)
+       ELSE 
+         zmfux(i,k)= (zmfux(i,k+1) + zpen_u(i,k)*zx(i,k) ) / 
+     .               (1.+zpde_u(i,k)/MAX(zmfmin,pmfu(i,k)))
+         xu(i,k)=zmfux(i,k)/MAX(zmfmin,pmfu(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c--calcul des flux dans le panache descendant
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kdtop(i)-1) THEN
+         xd(i,k)=( zx(i,k)+xu(i,k) ) / 2. 
+         zmfdx(i,k+1)=pmfd(i,k+1)*xd(i,k)
+       ELSE
+         zmfdx(i,k+1)= (zmfdx(i,k) - zpen_d(i,k)*zx(i,k) ) /
+     .               (1.-zpde_d(i,k)/MIN(-zmfmin,pmfd(i,k+1)))
+         xd(i,k)=zmfdx(i,k+1)/MIN(-zmfmin,pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfdx(i,klev+1) = 0.0 
+         xd(i,klev) = (zpen_d(i,klev)*zx(i,klev) - zmfdx(i,klev)) / 
+     .                   MAX(zmfmin,zpde_d(i,klev)) 
+      ENDDO 
+c
+c--introduction du flux de retour dans l'environnement
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kctop(i)-3) THEN 
+         xe(i,k)= zx(i,k) 
+         zmfex(i,k+1)=-(pmfu(i,k+1)+pmfd(i,k+1))*xe(i,k)
+       ELSE 
+         zmfex(i,k+1)= (zmfex(i,k) - 
+     .      (zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i,k))) /
+     .      (1.-(zpen_d(i,k)+zpen_u(i,k))/
+     .      MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) )
+         xe(i,k)=zmfex(i,k+1)/MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfex(i,klev+1) = 0.0
+         xe(i,klev) = (zpde_u(i,klev)*xu(i,klev) + 
+     .                 zpde_d(i,klev)*xd(i,klev) -zmfex(i,klev)) /
+     .                 MAX(zmfmin,zpen_u(i,klev)+zpen_d(i,klev)) 
+      ENDDO
+c
+c--calcul final des tendances
+c
+      DO k=1 , klev
+      DO i=1, klon
+        dx(i,klev+1-k) = RG/(paph(i,k+1)-paph(i,k))*pdtime*
+     .                      ( zmfux(i,k+1) - zmfux(i,k) +
+     .                        zmfdx(i,k+1) - zmfdx(i,k) +
+     .                        zmfex(i,k+1) - zmfex(i,k) )
+      ENDDO
+      ENDDO
+c
+      RETURN 
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fonte_neige_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fonte_neige_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/fonte_neige_mod.F90	(revision 984)
@@ -0,0 +1,343 @@
+!
+! $Header$
+!
+MODULE fonte_neige_mod
+!
+! This module will treat the process of snow, melting, accumulating, calving, in 
+! case of simplified soil model.
+!
+!****************************************************************************************
+  USE dimphy, ONLY : klon
+
+  IMPLICIT NONE
+  SAVE
+
+! run_off_ter and run_off_lic are the runoff at the compressed grid knon for 
+! land and land-ice respectively
+! Note: run_off_lic is used in mod_landice and therfore not private
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_ter
+  !$OMP THREADPRIVATE(run_off_ter)
+  REAL, ALLOCATABLE, DIMENSION(:)             :: run_off_lic
+  !$OMP THREADPRIVATE(run_off_lic)
+
+! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_lic_0
+  !$OMP THREADPRIVATE(run_off_lic_0)
+  
+  REAL, PRIVATE                               :: tau_calv  
+  !$OMP THREADPRIVATE(tau_calv)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: ffonte_global
+  !$OMP THREADPRIVATE(ffonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqfonte_global
+  !$OMP THREADPRIVATE(fqfonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqcalving_global
+  !$OMP THREADPRIVATE(fqcalving_global)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_init(restart_runoff)
+
+! This subroutine allocates and initialize variables in the module. 
+! The variable run_off_lic_0 is initialized to the field read from
+! restart file. The other variables are initialized to zero.
+!
+    INCLUDE "indicesol.h"
+!****************************************************************************************
+! Input argument
+    REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff 
+
+! Local variables
+    INTEGER                           :: error
+    CHARACTER (len = 80)              :: abort_message 
+    CHARACTER (len = 20)              :: modname = 'fonte_neige_init'
+
+
+!****************************************************************************************
+! Allocate run-off at landice and initilize with field read from restart
+!
+!****************************************************************************************
+
+    ALLOCATE(run_off_lic_0(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic_0(:) = restart_runoff(:) 
+
+!****************************************************************************************
+! Allocate other variables and initilize to zero
+!
+!****************************************************************************************
+    ALLOCATE(run_off_ter(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_ter'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_ter(:) = 0.
+    
+    ALLOCATE(run_off_lic(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic(:) = 0.
+    
+    ALLOCATE(ffonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation ffonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    ffonte_global(:,:) = 0.0
+
+    ALLOCATE(fqfonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqfonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqfonte_global(:,:) = 0.0
+
+    ALLOCATE(fqcalving_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqcalving_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqcalving_global(:,:) = 0.0
+
+!****************************************************************************************
+! Read tau_calv
+!
+!****************************************************************************************
+    CALL conf_interface(tau_calv)
+
+
+  END SUBROUTINE fonte_neige_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, &
+       tsurf, precip_rain, precip_snow, &
+       snow, qsol, tsurf_new, evap)
+        
+! Routine de traitement de la fonte de la neige dans le cas du traitement
+! de sol simplifie!
+! LF 03/2001
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   knindex      index des mailles valables pour surface a traiter
+!   dtime        
+!   tsurf        temperature de surface
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!
+! input/output:
+!   snow         champs hauteur de neige
+!   qsol         hauteur d'eau contenu dans le sol
+!   tsurf_new    temperature au sol
+!   evap
+!
+  INCLUDE "indicesol.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "FCTTRE.h"
+  INCLUDE "clesphys.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, INTENT(IN)                  :: nisurf
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+    
+! Input/Output variables
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: qsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(INOUT) :: evap
+
+! Local variables
+!****************************************************************************************
+
+    INTEGER               :: i, j
+    REAL                  :: fq_fonte
+    REAL                  :: coeff_rel
+    REAL, PARAMETER       :: snow_max=3000.
+    REAL, PARAMETER       :: max_eau_sol = 150.0
+!! PB temporaire en attendant mieux pour le modele de neige
+! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15)
+    REAL, PARAMETER       :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!IM cf JLD/ GKtest
+    REAL, PARAMETER       :: chaice = 3.334E+05/(2.3867E+06*0.15)
+! fin GKtest
+    REAL, DIMENSION(klon) :: ffonte
+    REAL, DIMENSION(klon) :: fqcalving, fqfonte
+    REAL, DIMENSION(klon) :: d_ts
+    REAL, DIMENSION(klon) :: bil_eau_s, snow_evap
+
+    LOGICAL               :: neige_fond
+
+!****************************************************************************************
+! Start calculation
+! - Initialization
+!
+!****************************************************************************************
+    coeff_rel = dtime/(tau_calv * rday)
+    
+    bil_eau_s(:) = 0.
+
+!****************************************************************************************
+! - Increment snow due to precipitation and evaporation
+! - Calculate the water balance due to precipitation and evaporation (bil_eau_s)
+!
+!****************************************************************************************
+    WHERE (precip_snow > 0.) 
+       snow = snow + (precip_snow * dtime)
+    END WHERE
+
+    snow_evap = 0.
+    WHERE (evap > 0. ) 
+       snow_evap = MIN (snow / dtime, evap) 
+       snow = snow - snow_evap * dtime
+       snow = MAX(0.0, snow)
+    END WHERE
+    
+    bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime
+
+
+!****************************************************************************************
+! - Calculate melting snow
+! - Calculate calving and decrement snow, if there are to much snow
+! - Update temperature at surface
+!
+!****************************************************************************************
+
+    ffonte(:) = 0.0
+    fqcalving(:) = 0.0
+    fqfonte(:) = 0.0
+    DO i = 1, knon
+       ! Y'a-t-il fonte de neige?
+       neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+            .AND. tsurf_new(i) >= RTT)
+       IF (neige_fond) THEN
+          fq_fonte     = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
+          ffonte(i)    = fq_fonte * RLMLT/dtime
+          fqfonte(i)   = fq_fonte/dtime
+          snow(i)      = MAX(0., snow(i) - fq_fonte)
+          bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
+          tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+
+!IM cf JLD OK     
+!IM cf JLD/ GKtest fonte aussi pour la glace
+          IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN
+             fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0)
+             ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime
+             IF ( ok_lic_melt ) THEN
+                fqfonte(i) = fqfonte(i) + fq_fonte/dtime
+                bil_eau_s(i) = bil_eau_s(i) + fq_fonte
+             ENDIF
+             tsurf_new(i) = RTT
+          ENDIF
+          d_ts(i) = tsurf_new(i) - tsurf(i)
+       ENDIF
+
+       ! s'il y a une hauteur trop importante de neige, elle s'coule
+       fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime
+       snow(i)=MIN(snow(i),snow_max)
+    END DO
+
+
+    IF (nisurf == is_ter) THEN
+       DO i = 1, knon
+          qsol(i) = qsol(i) + bil_eau_s(i)
+          run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+          qsol(i) = MIN(qsol(i), max_eau_sol) 
+       END DO
+    ELSE IF (nisurf == is_lic) THEN
+       DO i = 1, knon
+          j = knindex(i)
+          run_off_lic(i)   = (coeff_rel *  fqcalving(i)) + &
+               (1. - coeff_rel) * run_off_lic_0(j)
+          run_off_lic_0(j) = run_off_lic(i)
+          run_off_lic(i)   = run_off_lic(i) + fqfonte(i)/dtime
+       END DO
+    ENDIF
+    
+!****************************************************************************************
+! Save ffonte, fqfonte and fqcalving in global arrays for each 
+! sub-surface separately
+!
+!****************************************************************************************
+    DO i = 1, knon
+       ffonte_global(knindex(i),nisurf)    = ffonte(i)
+       fqfonte_global(knindex(i),nisurf)   = fqfonte(i)
+       fqcalving_global(knindex(i),nisurf) = fqcalving(i)
+    ENDDO
+
+  END SUBROUTINE fonte_neige
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_final(restart_runoff)
+!
+! This subroutine returns run_off_lic_0 for later writing to restart file.
+!
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff
+
+!****************************************************************************************
+! Set the output variables
+    restart_runoff(:) = run_off_lic_0(:)
+
+! Deallocation of all varaibles in the module
+    DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, &
+         fqfonte_global, fqcalving_global)
+
+  END SUBROUTINE fonte_neige_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, &
+       fqfonte_out, ffonte_out)
+
+! Cumulate ffonte, fqfonte and fqcalving respectively for
+! all type of surfaces according to their fraction.
+!
+! This routine is called from physiq.F before histwrite.
+
+    INCLUDE "indicesol.h"
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqcalving_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqfonte_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: ffonte_out
+
+    INTEGER   :: nisurf
+!****************************************************************************************
+
+    ffonte_out(:)    = 0.0
+    fqfonte_out(:)   = 0.0
+    fqcalving_out(:) = 0.0
+
+    DO nisurf = 1, nbsrf
+       ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf)
+    ENDDO
+
+  END SUBROUTINE fonte_neige_get_vars
+!
+!****************************************************************************************
+!
+END MODULE fonte_neige_mod
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/haut2bas.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/haut2bas.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/haut2bas.F	(revision 984)
@@ -0,0 +1,19 @@
+!
+! $Header$
+!
+      SUBROUTINE haut2bas(klon, klev, varB2H, varH2B)
+      IMPLICIT NONE
+c
+      INTEGER klon, klev
+      REAL varB2H(klon, klev), varH2B(klon, klev)
+      INTEGER i, k, kinv
+c
+      DO k=1,klev  
+       kinv=klev-k+1 
+       DO i=1,klon
+        varH2B(i,k)=varB2H(i,kinv)
+       ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hbtm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hbtm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hbtm.F	(revision 984)
@@ -0,0 +1,777 @@
+!
+! $Header$
+!
+
+      SUBROUTINE HBTM(knon, paprs, pplay,
+     .                t2m,t10m,q2m,q10m,ustar,
+     .                flux_t,flux_q,u,v,t,q,
+     .                pblh,cape,EauLiq,ctei,pblT,
+     .                therm,trmb1,trmb2,trmb3,plcl)
+        USE dimphy
+        IMPLICIT none
+
+c***************************************************************
+c*                                                             *
+c* HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
+c*                 JAS 47              BLM                     *
+c* Algorithme These Anne Mathieu                               *
+c* Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+c* written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+c* features : implem. exces Mathieu                            *
+c***************************************************************
+c* mods : decembre 99 passage th a niveau plus bas. voir fixer *
+c* la prise du th a z/Lambda = -.2 (max Ray)                   *
+c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
+c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
+c* voir aussi //KE pblh = niveau The_e ou l = env.             *
+c***************************************************************
+c* fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+c***************************************************************
+c*
+c
+c
+cAM Fev 2003
+c Adaptation a LMDZ version couplee
+c
+c Pour le moment on fait passer en argument les grdeurs de surface : 
+c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms 
+c on garde la possibilite de changer si besoin est (jusqu'a present la 
+c forme de HB avec le 1er niveau modele etait conservee)
+c
+c
+c
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL RLvCp, REPS
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+cAM
+      REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+      REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+      REAL ustar(klon)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL flux_t(klon,klev), flux_q(klon,klev)     ! Flux 
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+cAM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+cAM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+cum      PARAMETER (isommet=klev) ! limite max sommet pbl
+      REAL vk
+      PARAMETER (vk=0.35)     ! Von Karman => passer a .41 ! cf U.Olgstrom
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)     ! b calcul du Prandtl et de dTetas
+      REAL fakn
+      PARAMETER (fakn=7.2)    ! a
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)  ! pour Phim / h dans la S.L stable
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)   ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+      REAL sffrac
+      PARAMETER (sffrac=0.1)  ! S.L. = z/h < .1
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL q_star,t_star
+      REAL b1,b2,b212,b2sr     ! Lambert correlations T' q' avec T* q*
+      PARAMETER (b1=70.,b2=20.)
+c
+      REAL z(klon,klev)
+cAM      REAL pcfm(klon,klev), pcfh(klon,klev)
+cAM
+      REAL zref
+      PARAMETER (zref=2.)    ! Niveau de ref a 2m peut eventuellement 
+c                              etre choisi a 10m
+cMA
+c
+      INTEGER i, k, j
+      REAL zxt
+cAM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+cAM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
+      REAL pblh(klon)
+      REAL pblT(klon)
+      REAL plcl(klon)
+cAM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+cAM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+cAM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)     ! Monin-Obukhov lengh
+cAM      REAL ztvd, ztvu, 
+      REAL zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL trmb1(klon),trmb2(klon),trmb3(klon)
+C  Algorithme thermique
+      REAL s(klon,klev)     ! [P/Po]^Kappa milieux couches
+      REAL Th_th(klon)      ! potential temperature of thermal
+      REAL The_th(klon)     ! equivalent potential temperature of thermal
+      REAL qT_th(klon)      ! total water  of thermal
+      REAL Tbef(klon)       ! T thermique niveau precedent
+      REAL qsatbef(klon)
+      LOGICAL Zsat(klon)    ! le thermique est sature
+      REAL Cape(klon)       ! Cape du thermique
+      REAL Kape(klon)       ! Cape locale
+      REAL EauLiq(klon)     ! Eau liqu integr du thermique
+      REAL ctei(klon)       ! Critere d'instab d'entrainmt des nuages de CL
+      REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat
+cIM 091204 BEG
+      REAL a1,a2,a3
+cIM 091204 END
+      REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2
+      REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the
+      REAL delt_qt,delt_2,quadsat,spblh,reduc
+c
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5
+cAM      REAL zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+
+! initialisations (Anne)
+      isommet=klev
+      th_th(:) = 0.
+      q_star = 0
+      t_star = 0
+
+
+      b212=sqrt(b1*b2)
+      b2sr=sqrt(b2)
+c
+C ============================================================
+C     Fonctions thermo implicites
+C ============================================================
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c Tetens : pression partielle de vap d'eau e_sat(T)
+c =================================================
+C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
+C++ avec :
+C++ Tf = 273.16 K  (Temp de fusion de la glace)
+C++ r2 = 611.14 Pa
+C++ r3 = 17.269 (liquide) 21.875 (solide) adim
+C++ r4 = 35.86             7.66           Kelvin
+C++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
+C++ deriv� :
+C++ =========
+C++                   r3*(Tf-r4)*q_sat(T,p)
+C++ d_qsat_dT = --------------------------------
+C++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
+c++ pour zcvm5=Lv, c'est FOEDE
+c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
+C     ------------------------------------------------------------------
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+
+c
+c      DO i = 1, klon
+c         pcfh(i,1) = cd_h(i)
+c         pcfm(i,1) = cd_m(i)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         pcfh(i,k) = zkmin
+c         pcfm(i,k) = zkmin
+c         cgs(i,k) = 0.0
+c         cgh(i,k) = 0.0
+c         cgq(i,k) = 0.0
+c      ENDDO
+c      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
+c  pourquoi ne pas utiliser Phi/RG ?
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+         s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa
+      ENDDO
+c                                 s(k) = [pplay(k)/ps]^kappa
+c    + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+c
+c    -----------------  paprs <-> sig(k)
+c
+c    + + + + + + + + + pplay  <-> s(k-1)
+c
+c
+c    + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+c
+c    -----------------  paprs <-> sig(1)
+c
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+         s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa
+      ENDDO
+      ENDDO
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++  Determination des grandeurs de surface  +++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      DO i = 1, knon
+cAM         IF (thermcep) THEN
+cAM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+c           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+c           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+cAM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+cAM           zxqs=MIN(0.5,zxqs)
+cAM           zcor=1./(1.-retv*zxqs)
+cAM           zxqs=zxqs*zcor
+cAM         ELSE
+cAM           IF (tsol(i).LT.t_coup) THEN
+cAM              zxqs = qsats(tsol(i)) / paprs(i,1)
+cAM           ELSE
+cAM              zxqs = qsatl(tsol(i)) / paprs(i,1)
+cAM           ENDIF
+cAM         ENDIF
+c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique
+cAM        zx_alf1 = 1.0
+cAM        zx_alf2 = 1.0 - zx_alf1
+cAM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .        *(1.+RETV*q(i,1))*zx_alf1
+cAM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+cAM     .        *(1.+RETV*q(i,2))*zx_alf2
+cAM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+cAM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+cAM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+cAM      
+cAMAM           zxu = u10m(i)
+cAMAM           zxv = v10m(i)
+cAMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
+cAM Niveau de ref choisi a 2m
+        zxt = t2m(i)
+
+c ***************************************************
+c attention, il doit s'agir de <w'theta'>
+c   ;Calcul de tcls virtuel et de w'theta'virtuel
+c   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+c   tcls=tcls*(1+.608*qcls)
+c
+c   ;Pour avoir w'theta',
+c   ; il faut diviser par ro.Cp
+c   Cp=Cpd*(1+0.84*qcls)
+c   fcs=fcs/(ro_surf*Cp)
+c   ;On transforme w'theta' en w'thetav'
+c   Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+c   xle=xle/(ro_surf*Lv)
+c   fcsv=fcs+.608*xle*tcls
+c ***************************************************
+cAM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+cAM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+cAM
+cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+cAM calcule de Ro = paprs(i,1)/Rd zxt
+cAM convention >0 vers le bas ds lmdz 
+        khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1))
+        kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1))
+cAM   verifier que khfs et kqfs sont bien de la forme w'l'
+        heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
+c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+cAM        heatv(i) = khfs(i)
+cAM ustar est en entree
+cAM        taux = zxu *zxmod*cd_m(i)
+cAM        tauy = zxv *zxmod*cd_m(i)
+cAM        ustar(i) = SQRT(taux**2+tauy**2)
+cAM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+c Theta et qT du thermique sans exces (interpolin vers surf)
+c chgt de niveau du thermique (jeudi 30/12/1999)
+c (interpolation lineaire avant integration phi_h)
+cAM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
+cAM        qT_th(i) = max(qT_th(i),q(i,1))
+        qT_th(i) = q2m(i)
+cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
+cn reste a regler convention P) pour Theta
+c        The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+c     -                      + RLvCp*qT_th(i)
+cAM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+        Th_th(i) = t2m(i)
+      ENDDO
+c
+      DO i = 1, knon
+         rhino(i,1) = 0.0   ! Global Richardson
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)   ! on initialise pblh a l'altitude du 1er niveau
+         plcl(i) = 6000.
+c Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+         trmb1(i)   = 0.
+         trmb2(i)   = 0.
+         trmb3(i) = 0.
+      ENDDO
+
+C
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      fac = 100.0
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
+c passer par Theta_e et virpot)
+c         zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
+cAM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i))
+c  Le Ri par Theta_v
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+cAM On a nveau de ref a 2m ???
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+c ***************************************************
+c Wm ? et W* ? c'est la formule pour z/h < .1
+c   ;Calcul de w* ;;
+c   ;;;;;;;;;;;;;;;;
+c   w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
+c   ;; CALCUL DE wm ;;
+c   ;;;;;;;;;;;;;;;;;;
+c   ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
+c   ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+c   ;;;;;;;;;;;Dans la couche de surface
+c   if (z(ind) le 20) then begin
+c   Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+c   wm=u_star/Phim
+c   ;;;;;;;;;;;En dehors de la couche de surface
+c   endif else if (z(ind) gt 20) then begin
+c   wm=(u_star^3+c1*w_star^3)^(1/3.)
+c   endif
+c ***************************************************
+        wm(i)= ustar(i)*phiminv(i)
+c======================================================================
+cvaleurs de Dominique Lambert de la campagne SEMAPHORE :
+c <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+c <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
+c et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+c avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+c(leur corellation pourrait dependre de beta par ex)
+c  if fcsv(i,j) gt 0 then begin
+c    dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+c    (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+c    2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
+c    dqs=b2*(xle(i,j)/wm(i,j))^2
+c    theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+c    q_s(i,j)=q_10(i,j)+sqrt(dqs)
+c  endif else begin
+c    Theta_s(i,j)=thetav_10(i,j)
+c    q_s(i,j)=q_10(i,j)
+c  endelse
+c======================================================================
+c
+cHBTM        therm(i) = heatv(i)*fak/wm(i)
+c forme Mathieu :
+        q_star = kqfs(i)/wm(i)
+        t_star = khfs(i)/wm(i)
+cIM 091204 BEG
+        IF(1.EQ.0) THEN
+        IF(t_star.LT.0..OR.q_star.LT.0.) THEN
+          print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star,
+     $    khfs(i),kqfs(i),wm(i)
+        ENDIF
+        ENDIF
+cIM 091204 END
+cAM Nveau cde ref 2m =>
+cAM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
+cAM     +             + (RETV*T(i,1))**2*b2*q_star**2
+cAM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
+cAM     +                 )
+cIM 091204 BEG
+        a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2
+        a2=(RETV*Th_th(i))**2*b2*q_star*q_star
+        a3=2.*RETV*Th_th(i)*b212*q_star*t_star
+        aa=a1+a2+a3
+        IF(1.EQ.0) THEN
+        IF (aa.LT.0.) THEN 
+         print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa
+         print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212',
+     $   i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212
+        ENDIF
+        ENDIF
+cIM 091204 END
+        therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     +             + (RETV*Th_th(i))**2*b2*q_star*q_star
+cIM 101204  +             + 2.*RETV*Th_th(i)*b212*q_star*t_star
+     +             + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star)
+     +                 )
+c
+c Theta et qT du thermique (forme H&B) avec exces
+c (attention, on ajoute therm(i) qui est virtuelle ...)
+c pourquoi pas sqrt(b1)*t_star ?
+c        dqs = b2sr*kqfs(i)/wm(i)
+        qT_th(i) = qT_th(i)  + b2sr*q_star
+cnew on differre le calcul de Theta_e
+c        The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+        rhino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++ Improve pblh estimate for unstable conditions using the +++++++
+C ++          convective temperature excess :                +++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c et therm Theta_v (avec hypothese de constance de H&B,
+c         zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i)
+
+c
+c  Le Ri par Theta_v
+cAM Niveau de ref 2m
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+cIM 170305 BEG
+      IF(1.EQ.0) THEN
+c debug print -120;34       -34-        58 et    0;26 wamp
+      if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then
+            print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i)
+            q_star = kqfs(i)/wm(i)
+            t_star = khfs(i)/wm(i)
+            print*,'q* t*, b1,b2,b212 ',q_star,t_star
+     -            , b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     -            , (RETV*Th_th(i))**2*b2*q_star**2
+     -            , 2.*RETV*Th_th(i)*b212*q_star*t_star
+            print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2
+      endif
+      ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+c             q_star = kqfs(i)/wm(i)
+c             t_star = khfs(i)/wm(i)
+c             trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
+c             trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
+c Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+c par exemple :
+        pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
+     .              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+      ENDDO
+
+C ********************************************************************
+C  pblh is now available; do preparation for diffusivity calculation :
+C ********************************************************************
+      DO i = 1, knon
+        check(i) = .TRUE.
+        Zsat(i)   = .FALSE.
+c omegafl utilise pour prolongement CAPE
+        omegafl(i) = .FALSE.
+        Cape(i)   = 0.
+        Kape(i)   = 0.
+        EauLiq(i) = 0.
+        CTEI(i)   = 0.
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C *** Rq: les formule sont prises dans leur forme CS ***
+        IF (unstbl(i)) THEN
+cAM Niveau de ref du thermique
+cAM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .         *(1.+RETV*q(i,1))
+          zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i)))
+     .         *(1.+RETV*qT_th(i))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+c Computes Theta_e for thermal (all cases : to be modified)
+c   attention ajout therm(i) = virtuelle
+        The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+C debug
+c          if (i.EQ.1864) then
+c             print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
+c          endif
+
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+c        print*,'fin calcul niveaux'
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms zero'
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+c            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+c            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+c            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms non zero'
+C
+C For all unstable layers, compute diffusivities and ctrgrad ter m
+C
+c        DO i = 1, knon
+c        IF (unslev(i)) THEN
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pblk(i)/pr(i)
+c etc cf original
+c        ENDIF
+c        ENDDO
+C
+C For all layers, compute integral info and CTEI
+C
+        DO i = 1, knon
+        if (check(i).or.omegafl(i)) then
+          if (.not.Zsat(i)) then
+c            Th2 = The_th(i) - RLvCp*qT_th(i)
+            Th2 = Th_th(i)
+            T2 = Th2*s(i,k)
+c thermodyn functions
+            zdelta=MAX(0.,SIGN(1.,RTT-T2))
+            qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k)
+            qqsat=MIN(0.5,qqsat)
+            zcor=1./(1.-retv*qqsat)
+            qqsat=qqsat*zcor
+c
+            if (qqsat.lt.qT_th(i)) then
+c on calcule lcl
+              if (k.eq.2) then
+                plcl(i) = z(i,k)
+              else
+                plcl(i) =  z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .                 (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat)
+              endif
+              Zsat(i) = .true.
+              Tbef(i) = T2
+            endif
+c
+          endif
+          qsatbef(i) = qqsat
+camn ???? cette ligne a deja ete faite normalement ?
+        endif
+c            print*,'hbtm2 i,k=',i,k
+        ENDDO
+ 1000 continue           ! end of level loop
+cIM 170305 BEG
+        IF(1.EQ.0) THEN
+            print*,'hbtm2  ok'
+        ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hgardfou.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hgardfou.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hgardfou.F	(revision 984)
@@ -0,0 +1,119 @@
+!
+! $Header$
+!
+      SUBROUTINE hgardfou (t,tsol,text)
+      use dimphy
+      IMPLICIT none
+c======================================================================
+c Verifier la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+      REAL t(klon,klev), tsol(klon,nbsrf)
+      CHARACTER*(*) text
+C
+      INTEGER i, k, nsrf
+      REAL zt(klon)
+      INTEGER jadrs(klon), jbad
+      LOGICAL ok
+c
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall /.TRUE./
+      IF (firstcall) THEN
+         PRINT*, 'hgardfou garantit la temperature dans [100,370] K'
+         firstcall = .FALSE.
+      ENDIF
+c
+      ok = .TRUE.
+      DO k = 1, klev
+         DO i = 1, klon
+            zt(i) = t(i,k)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+         DO i = 1, klon
+            zt(i) = tsol(i,nsrf)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      IF (.NOT. ok) THEN
+         PRINT*, 'hgardfou s arrete ', text
+         CALL abort
+      ENDIF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/histo_o500_pctau.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/histo_o500_pctau.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/histo_o500_pctau.F	(revision 984)
@@ -0,0 +1,67 @@
+!
+! $Header$
+!
+      SUBROUTINE histo_o500_pctau(nbreg,pct_ocean,w,histo,histoW,nhisto)
+      USE dimphy
+      IMPLICIT none
+
+      INTEGER :: ij, k, l, nw
+      INTEGER :: nreg, nbreg
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      INTEGER, PARAMETER :: kmax=8, lmax=8
+      INTEGER, PARAMETER :: kmaxm1=kmax-1, lmaxm1=lmax-1
+      INTEGER, PARAMETER :: iwmax=40
+
+      INTEGER, dimension(klon) :: iw
+      REAL, dimension(klon) :: w
+      REAL, PARAMETER :: wmin=-200., pas_w=10.
+      REAL, dimension(kmaxm1,lmaxm1,iwmax,nbreg) :: histoW, nhisto
+      REAL, dimension(klon,kmaxm1,lmaxm1) :: histo
+
+!     LOGICAL, dimension(klon,nbreg) :: pct_ocean
+      INTEGER, dimension(klon,nbreg) :: pct_ocean
+
+! initialisation
+      histoW(:,:,:,:)=0.      
+      nhisto(:,:,:,:)=0.   
+!   
+!calcul de l'histogramme de chaque regime dynamique
+      DO nreg=1, nbreg
+       DO ij=1, klon
+        iw(ij) = int((w(ij)-wmin)/pas_w) +1
+c       IF(pct_ocean(ij,nreg)) THEN
+c       IF(pct_ocean(ij,nreg).EQ.1) THEN
+         IF(iw(ij).GE.1.AND.iw(ij).LE.iwmax) THEN 
+          DO l=1, lmaxm1
+           DO k=1, kmaxm1
+            IF(histo(ij,k,l).GT.0.) THEN
+             histoW(k,l,iw(ij),nreg) = histoW(k,l,iw(ij),nreg) 
+     &       + histo(ij,k,l)*pct_ocean(ij,nreg)
+             nhisto(k,l,iw(ij),nreg)= nhisto(k,l,iw(ij),nreg) + 
+     &       pct_ocean(ij,nreg)
+            ENDIF
+           ENDDO !k
+          ENDDO !l
+c        ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw
+c         PRINT*,'ij,iw=',ij,iw(ij)
+         ENDIF !iw
+c       ENDIF !pct_ocean
+       ENDDO !ij
+!normalisation
+       DO nw=1, iwmax
+        DO l=1, lmaxm1
+         DO k=1, kmaxm1
+          IF(nhisto(k,l,nw,nreg).NE.0.) THEN
+           histoW(k,l,nw,nreg) = 100.*histoW(k,l,nw,nreg)
+     &     /nhisto(k,l,nw,nreg)
+c          PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg,
+c    &     histoW(k,l,nw,nreg)
+          ENDIF
+         ENDDO !k
+        ENDDO !l
+       ENDDO !nw
+      ENDDO !nreg
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/homogene.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/homogene.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/homogene.F	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE homogene(paprs, q, dq, u,v, du, dv)
+      USE dimphy
+      IMPLICIT NONE
+c==============================================================
+c Schema ad hoc du melange vertical pour les vitesses u et v,
+c a appliquer apres le schema de convection (fiajc et fiajh).
+c
+c paprs:input, pression demi-couche (inter-couche)
+c q:    input, vapeur d'eau (kg/kg)
+c dq:   input, incrementation de vapeur d'eau (de la convection)
+c u:    input, vitesse u
+c v:    input, vitesse v
+c
+c du:   output, incrementation pour u
+c dv:   output, incrementation pour v
+c==============================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      REAL paprs(klon,klev+1)
+      REAL q(klon,klev), dq(klon,klev)
+      REAL u(klon,klev), du(klon,klev)
+      REAL v(klon,klev), dv(klon,klev)
+c
+      REAL zm_dq(klon) ! quantite totale de l'eau deplacee
+      REAL zm_q(klon)  ! quantite totale de la vapeur d'eau
+      REAL zm_u(klon)  ! moyenne de u (brassage parfait et total)
+      REAL zm_v(klon)  ! moyenne de v (brassage parfait et total)
+      REAL z_frac(klon) ! fraction du brassage parfait et total
+      REAL zm_dp(klon)
+c
+      REAL zx
+      INTEGER i, k
+      REAL frac_max
+      PARAMETER (frac_max=0.1)
+      REAL seuil
+      PARAMETER (seuil=1.0e-10)
+      LOGICAL faisrien
+      PARAMETER (faisrien=.true.)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         du(i,k) = 0.0
+         dv(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      IF (faisrien) RETURN
+c
+      DO i = 1, klon
+         zm_dq(i)=0.
+         zm_q(i) =0.
+         zm_u(i)=0.
+         zm_v(i)=0.
+         zm_dp(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (ABS(dq(i,k)).GT.seuil) THEN
+         zx = paprs(i,k) - paprs(i,k+1)
+         zm_dq(i) = zm_dq(i) + ABS(dq(i,k))*zx
+         zm_q(i) = zm_q(i) + q(i,k)*zx
+         zm_dp(i) = zm_dp(i) + zx
+         zm_u(i) = zm_u(i) + u(i,k)*zx
+         zm_v(i) = zm_v(i) + v(i,k)*zx
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Hypothese principale: apres la convection, la vitesse de chaque
+c couche est composee de deux parties: celle (1-z_frac) de la vitesse 
+c original et celle (z_frac) de la vitesse moyenne qui serait la
+c vitesse de chaque couche si le brassage etait parfait et total.
+c La fraction du brassage est calculee par le rapport entre la quantite
+c totale de la vapeur d'eau deplacee (ou condensee) et la quantite
+c totale de la vapeur d'eau. Et cette fraction est limitee a frac_max 
+c (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995).
+c
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.0E-15 .AND. zm_q(i).GE.1.0E-15) THEN
+         z_frac(i)=MIN(frac_max,zm_dq(i)/zm_q(i))
+         zm_u(i)=zm_u(i)/zm_dp(i)
+         zm_v(i)=zm_v(i)/zm_dp(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.e-15 .AND. zm_q(i).GE.1.e-15
+     .                         .AND. ABS(dq(i,k)).GT.seuil) THEN
+         du(i,k) = u(i,k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i,k)
+         dv(i,k) = v(i,k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hydrol.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hydrol.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/hydrol.F	(revision 984)
@@ -0,0 +1,121 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap,
+     .                  agesno, tsol,qsol,snow,runoff)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940414
+c======================================================================
+c
+c Traitement de l'hydrologie du sol
+c ---------------------------------
+c rain_fall: taux de pluie
+c snow_fall: taux de neige
+c agesno: age de la neige
+c evap: taux d'evaporation
+c tsol: temperature du sol
+c qsol: humidite du sol
+c snow: couverture neigeuse
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c
+      REAL chasno ! epaisseur du sol: 0.15 m
+      PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15))
+      REAL mx_eau_sol
+      PARAMETER (mx_eau_sol=150.0)
+c
+      REAL dtime
+      REAL pctsrf(klon,nbsrf)
+      REAL snow(klon,nbsrf), tsol(klon,nbsrf), qsol(klon,nbsrf)
+      REAL snow_fall(klon), rain_fall(klon), evap(klon)
+      REAL runoff(klon), agesno(klon)
+C
+      INTEGER i, is
+      REAL subli, fsno
+C-----------------------------------------------------------------------
+      DO 99999 i = 1, klon
+c
+         runoff(i) = 0.0
+c
+         is = is_ter
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_lic
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+cIM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+cIM cf GK : la glace fond a 0C, non pas a -1.8
+            tsol(i,is) = MIN(tsol(i,is),RTT)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_sic
+         qsol(i,is) = 0.0
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+cIM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+cIM cf GK : la glace fond a 0C, non pas a -1.8
+            tsol(i,is) = MIN(tsol(i,is),RTT)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         agesno(i) = (agesno(i)+ (1.-agesno(i)/50.)*dtime/86400.)
+     .             * EXP(-1.*MAX(0.0,snow_fall(i))*dtime/0.3)
+         agesno(i) = MAX(agesno(i),0.0)
+c
+99999 CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/indicesol.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/indicesol.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/indicesol.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+!
+      INTEGER is_oce
+      PARAMETER (is_oce=3) ! ocean
+      INTEGER is_sic
+      PARAMETER (is_sic=4) ! glace de mer
+      INTEGER is_ter
+      PARAMETER (is_ter=1) ! terre
+      INTEGER is_lic
+      PARAMETER (is_lic=2) ! glacier continental
+!
+      REAL epsfra
+      PARAMETER (epsfra=1.0E-05)
+!
+      CHARACTER *3 clnsurf(nbsrf)
+      DATA clnsurf/'ter', 'lic', 'oce', 'sic'/
+      SAVE clnsurf
+!$OMP THREADPRIVATE(clnsurf)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_bilKP_ave.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_bilKP_ave.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_bilKP_ave.h	(revision 984)
@@ -0,0 +1,259 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+         zsto = dtime
+         zout = ecrit_day
+         typeval=tave
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         write(*,*)'zx_lon = ',zx_lon(:,1)
+cym         write(*,*)'zx_lat = ',zx_lat(1,:)
+cym         CALL histbeg("histbilKP_ave", iim,zx_lon(:,1), jjmp1,
+cym     .                zx_lat(1,:),
+cym     .                1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                nhori, nid_bilKPave)
+         CALL histbeg_phy("histbilKP_ave", itau_phy, zjulian, dtime,
+     .                nhori, nid_bilKPave)
+
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_bilKPave, "presnivs",
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPave,"ue",
+     .   "Zonal energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"ve",
+     .   "Merid energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"uq",
+     .   "Zonal humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vq",
+     .   "Merid humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPave,"temp",
+     .   "Air temperature","K",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"ovap",
+     .   "Specific humidity","Kg/Kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"geop",
+     .   "Geopotential height","m",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vitu",
+     .   "Zonal wind","m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vitv",
+     .   "Meridional wind","m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "vitw", 
+     .   "Vertical wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "pres", 
+     .   "Inter-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "play", 
+     .   "Mean-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "oliq", 
+     .   "Liquid water content", 
+     .                "kg/kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtdyn", 
+     .   "Dynamics dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqdyn", 
+     .   "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtcon", 
+     .   "Convection dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "ducon", 
+     .   "Convection du", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dvcon", 
+     .   "Convection dv", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqcon",
+     .   "Convection dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlsc", 
+     .   "Condensation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqlsc",
+     .   "Condensation dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dtvdf",
+     .   "Boundary-layer dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqvdf", 
+     .   "Boundary-layer dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dtajs",
+     .   "Ajustement sec dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqajs",
+     .   "Ajustement sec dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dteva", 
+     .   "Reevaporation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqeva",
+     .   "Reevaporation dQ",
+     .                "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+
+c
+         CALL histdef(nid_bilKPave, "dtswr", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtsw0", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlwr", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlw0", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"duvdf",
+     .   "Boundary-layer dU","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dvvdf",
+     .   "Boundary-layer dV","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         IF (ok_orodr) THEN
+         IF (ok_orolf) THEN
+         CALL histdef(nid_bilKPave, "duoli",
+     .   "Orography dU", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dvoli", 
+     .   "Orography dV", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF
+         ENDIF
+C
+         CALL histdef(nid_bilKPave, "duphy",
+     .   "Physiq dU","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dvphy",
+     .   "Physiq dV","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dtphy",
+     .   "Physiq dT","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dqphy",
+     .   "Physiq dQ","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dqlphy",
+     .   "Physiq dQl","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+C
+         CALL histend(nid_bilKPave)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_bilKP_ins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_bilKP_ins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_bilKP_ins.h	(revision 984)
@@ -0,0 +1,326 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+         zsto = dtime
+         zout = dtime
+         typeval=tinst
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         write(*,*)'zx_lon = ',zx_lon(:,1)
+cym         write(*,*)'zx_lat = ',zx_lat(1,:)
+c
+cIM 280405 BEG
+c
+cIM cf. AM 081204 BEG region
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+cym          do i=1,iim-1
+cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+cym          enddo
+cym          do j=1,jjmp1
+cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+cym          enddo
+c
+          print*,'On stoke le fichier bilKP instantanne sur ',
+     s   imin_ins,imax_ins,jmin_ins,jmax_ins
+          print*,'On stoke le fichier bilKP instantanne sur ',
+     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+cIM cf. AM 081204 END region
+c
+cIM 280405 END
+c
+cym         IF(1.EQ.0) THEN
+cym         CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), jjmp1,
+cym     .                zx_lat(1,:),
+cym     .                1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                nhori, nid_bilKPins)
+         ENDIF
+c
+cIM 280405 BEG
+c
+cIM cf. AM 081204 BEG region
+cym         CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), 
+cym     .                 jjmp1,zx_lat(1,:),
+cym     .                 imin_ins,imax_ins-imin_ins+1,
+cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_bilKPins)
+         CALL histbeg_phy("histbilKP_ins", itau_phy, zjulian, dtime,
+     .                 nhori, nid_bilKPins)
+cIM 081204 END
+c
+cIM 280405 END
+c
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_bilKPins, "presnivs",
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPins,"ue",
+     .   "Zonal energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"ve",
+     .   "Merid energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"uq",
+     .   "Zonal humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vq",
+     .   "Merid humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPins, "temp",
+     .   "Air temperature", "K",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"ovap",
+     .   "Specific humidity","Kg/Kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"geop",
+     .   "Geopotential height", "m",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vitu", 
+     .   "Zonal wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vitv", 
+     .   "Meridional wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "vitw",
+     .   "Vertical wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "pres",
+     .   "Inter-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "play",
+     .   "Mean-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "oliq",
+     .   "Liquid water content", 
+     .                "kg/kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtdyn",
+     .   "Dynamics dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dqdyn",
+     .   "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtcon",
+     .   "Convection dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "ducon",
+     .   "Convection du", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dvcon",
+     .   "Convection dv", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqcon",
+     .   "Convection dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlsc",
+     .   "Condensation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqlsc",
+     .   "Condensation dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dtvdf",
+     .   "Boundary-layer dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dqvdf", 
+     .   "Boundary-layer dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dtajs",
+     .   "Ajustement sec dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqajs",
+     .   "Ajustement sec dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dteva",
+     .   "Reevaporation dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqeva",
+     .   "Reevaporation dQ",
+     .                "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+
+c
+         CALL histdef(nid_bilKPins, "dtswr", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtsw0", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlwr", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlw0", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"duvdf",
+     .   "Boundary-layer dU","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dvvdf",
+     .   "Boundary-layer dV","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         IF (ok_orodr) THEN
+         IF (ok_orolf) THEN
+         CALL histdef(nid_bilKPins, "duoli", 
+     .   "Orography dU", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dvoli", 
+     .   "Orography dV", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF
+         ENDIF
+C
+         CALL histdef(nid_bilKPins, "duphy",
+     .   "Physiq dU","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dvphy",
+     .   "Physiq dV","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dtphy",
+     .   "Physiq dT","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dqphy",
+     .   "Physiq dQ","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dqlphy",
+     .   "Physiq dQl","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+cIM 280405 BEG
+c
+c Champs 2D:
+c
+c u850, v850
+c        DO k=1, nlevSTD
+         DO k=1, 12
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+         IF(bb2.EQ."850") THEN 
+c
+          CALL histdef(nid_bilKPins, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jjphy_nb,nhori, 1,1,1, -99, 32,
+     .                typeval, zsto,zout)
+c
+          CALL histdef(nid_bilKPins, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jjphy_nb,nhori, 1,1,1, -99, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF !(bb2.EQ."850") 
+c
+         ENDDO !k=1, 12
+c
+cIM 280405 END
+c
+         CALL histend(nid_bilKPins)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_coord_REGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_coord_REGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_coord_REGDYN.h	(revision 984)
@@ -0,0 +1,81 @@
+c
+c $Header$
+c
+       nsrf=3
+       DO nreg=1, nbregdyn
+       DO i=1, klon
+
+c       IF (debut) THEN
+         IF(rlon(i).LT.0.) THEN
+           rlonPOS(i)=rlon(i)+360.
+         ELSE
+           rlonPOS(i)=rlon(i)  
+         ENDIF
+c       ENDIF
+
+        pct_ocean(i,nreg)=0
+
+c test si c'est 1 point d'ocean
+        IF(pctsrf(i,nsrf).EQ.1.) THEN
+
+         IF(nreg.EQ.1) THEN
+
+c TROP
+          IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+
+c PACIFIQUE NORD
+          ELSEIF(nreg.EQ.2) THEN
+           IF(rlat(i).GE.40.AND.rlat(i).LE.60.) THEN
+            IF(rlonPOS(i).GE.160..AND.rlonPOS(i).LE.235.) THEN 
+             pct_ocean(i,nreg)=1
+            ENDIF
+           ENDIF
+c CALIFORNIE ST-CU
+         ELSEIF(nreg.EQ.3) THEN
+          IF(rlonPOS(i).GE.220..AND.rlonPOS(i).LE.250.) THEN
+           IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN
+            pct_ocean(i,nreg)=1
+           ENDIF
+          ENDIF
+c HAWAI
+        ELSEIF(nreg.EQ.4) THEN 
+         IF(rlonPOS(i).GE.180..AND.rlonPOS(i).LE.220.) THEN
+          IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+         ENDIF
+c WARM POOL
+        ELSEIF(nreg.EQ.5) THEN 
+         IF(rlonPOS(i).GE.70..AND.rlonPOS(i).LE.150.) THEN
+          IF(rlat(i).GE.-5.AND.rlat(i).LE.20.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+         ENDIF
+        ENDIF !nbregdyn
+c TROP
+c        IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN
+c         pct_ocean(i)=.TRUE.
+c         WRITE(*,*) 'pct_ocean =',i, rlon(i), rlat(i)
+c          ENDIF !lon
+c         ENDIF !lat
+
+        ENDIF !pctsrf
+       ENDDO !klon
+       ENDDO !nbregdyn
+cIM 190504      ENDIF !ok_regdyn
+ 
+cIM somme de toutes les nhistoW BEG
+      IF (debut) THEN
+      DO nreg = 1, nbregdyn
+       DO k = 1, kmaxm1
+        DO l = 1, lmaxm1
+         DO iw = 1, iwmax
+          nhistoWt(k,l,iw,nreg)=0.
+         ENDDO !iw
+        ENDDO !l
+       ENDDO !k
+      ENDDO !nreg
+      ENDIF !(debut) THEN
+cIM 190504 BEG
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histISCCP.h	(revision 984)
@@ -0,0 +1,267 @@
+!
+! $Header$
+!
+      IF (ok_isccp) THEN
+c
+c$OMP MASTER
+      ndex2d = 0
+      ndex3d = 0
+c
+c pour les champs instantannes, il faut mettre la meme valeur pour
+c zout et zsto.
+c dtime est passe par ailleurs a histbeg
+c zstophy = frequence de stockage des champs tous les pdt physiques
+c zout = frequence d'ecriture des champs
+cIM 300505     zstophy = dtime 
+c appel du simulateur toutes les 3heures
+!IM on lit la frequence d'appel dans physiq.def
+!         zcals(1) = dtime *6.  !toutes les 3h (en s)
+          zcals(1) = freq_ISCCP !toutes les freq_ISCCP secondes
+        DO n=1, napisccp
+          zcalh(n) = zcals(n)/3600. !stoutes les Xh (en heures)
+        ENDDO !n
+c
+c ecriture 8 fois par jour
+c       zout = dtime * REAL(NINT(86400./dtime*ecrit_isccp))
+c ecriture toutes les 2h (12 fois par jour)
+c       zout = dtime * 4.
+c ecriture toutes les 1/2 h (48 fois par jour)
+c       zout = dtime
+c
+c       IF(freqout_isccp.EQ.1.) THEN
+c ecriture jounaliere
+!IM on ecrit les resultats du simulateur ISCCP toutes les 
+! ecrit_ISCCP secondes      zout_isccp(1) = ecrit_day !(en s)
+          zout_isccp(1) = ecrit_ISCCP !(en s)
+c ecriture mensuelle
+c         zout = dtime * ecrit_mth !(en s)
+        DO n=1, napisccp 
+          zoutj(n)=zout_isccp(n)/86400. !(en jours)
+c
+c le nombre de sous-colonnes ncol : ncol=(100.*zcalh)/zoutd
+          ncol(n)=NINT((100.*zcalh(n))/zoutj(n))
+          IF(ncol(n).GT.ncolmx) THEN
+           PRINT*,'Warning: Augmenter le nombre colonnes du simulateur'
+           PRINT*,'         ISCCP ncol=', ncol,' ncolmx=',ncolmx
+c          PRINT*,'n ncol',n,ncol(n)
+           CALL abort
+          ENDIF
+c
+        DO l=1, ncol(n)
+          vertlev(l,n)=float(l)
+        ENDDO !ncol
+c
+        ENDDO !n
+
+c       PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp
+c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c       write(*,*)'ISCCP ', itau_phy, zjulian
+c
+c
+c definition coordonnees lon,lat en globale
+c
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym        DO i = 1, iim
+cym          zx_lon(i,1) = rlon(i+1)
+cym          zx_lon(i,jjmp1) = rlon(i+1)
+cym        ENDDO
+
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+cIM BEG region
+cym Desole dans un premier temps le mode region ne marchera pas
+cym Il faudra voir dans un second temps pour l'implementer
+cym Mais cela posera des problemes au niveau de la reconstruction
+
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+cym          do i=1,iim-1
+cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+cym          enddo
+cym          do j=1,jjmp1
+cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+cym          enddo
+c
+          print*,'On stoke le fichier histISCCP sur ',
+     s   imin_ins,imax_ins,jmin_ins,jmax_ins
+cym          print*,'On stoke le fichier histISCCP instantanne sur ',
+cym     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+cym     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+cIM END region
+c
+        IF(1.EQ.0) THEN
+cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:),
+cym     .                 1, iim, 1, jjmp1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_isccp)
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,
+     .                 nhori, nid_isccp)
+        ENDIF !(1.EQ.0) THEN
+c
+cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),
+cym     .                 jjmp1,zx_lat(1,:),
+cym     .                 imin_ins,imax_ins-imin_ins+1,
+cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_isccp)
+
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,
+     .                 nhori, nid_isccp)
+c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+         CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb",
+     .                 lmaxm1, cldtopres, nvert,'down')
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+         CALL histvert(nid_isccp,"cldtopres3","Cloud Top Pressure","mb",
+     .                 lmax3, cldtopres3, nvert3,'down')
+        ENDIF
+        DO n=1, napisccp
+         CALL histvert(nid_isccp, "Nbcol"//verticaxe(n),
+     .        "Nb of Column"//verticaxe(n),"1",
+     .        ncol(n), vertlev(:,n), nvlev(n),'up')
+        ENDDO
+c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+c variables a ecrire
+c 
+         DO n=1, napisccp
+c
+         DO k=1, kmaxm1
+          CALL histdef(nid_isccp, "cldISCCP_"//taulev(k)//verticaxe(n),
+     .                "LMDZ ISCCP cld", "%",
+     .                iim, jj_nb,nhori,lmaxm1,1,lmaxm1,nvert,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+         ENDDO
+c
+         CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),
+     .                "Nb of calls with sunlit ", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+         ENDDO
+c
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+         DO n=1, napisccp
+c
+c         print*,'n=',n,' avant histdef(..LMDZ ISCCP cld'
+c
+          DO k=1, kmaxm1
+           DO l=1, lmaxm1
+c
+           CALL histdef(nid_isccp, pclev(l)//taulev(k)//verticaxe(n),
+     .                "LMDZ ISCCP cld "//cnameisccp(l,k), "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+           ENDDO
+          ENDDO
+c
+c         print*,'n=',n,' avant histdef(..Nb of calls sunlit'
+          CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),
+     .                "Nb of calls with sunlit ", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c 9types de nuages ISCCP-D2
+          CALL histdef(nid_isccp, "cirr",
+     .                "Cirrus lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "cist",
+     .                "CiSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "deep",
+     .                "Deep lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "alcu",
+     .                "AlCu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "alst",
+     .                "AlSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "nist",
+     .                "NiSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "cumu",
+     .                "Cumu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "stcu",
+     .                "StCu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "stra",
+     .                "Stra lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c 3_epaisseurs_optiques x3_pressions_au_sommet_des_nuages  types de nuages 
+          CALL histdef(nid_isccp, "thin",
+     .                "Opt. thin ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "mid",
+     .                "Opt. intermediate ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "thick",
+     .                "Opt. thick ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c        IF(1.EQ.0) THEN
+c        IF(n.EQ.3) THEN
+c        IF(n.EQ.1) THEN
+c
+cIM 070905 BEG
+         IF(1.EQ.0) THEN
+          print*,'n=',n,' avant histdef(..boxptop axe'
+cIM verif boxptop
+          CALL histdef(nid_isccp,"boxptop"//verticaxe(n),
+     .                "Boxptop axe"//verticaxe(n), "mb",
+     .                iim, jj_nb,nhori,
+     .                ncol(n),1,ncol(n),nvlev(n),32,
+cIM  .                ncolmx,1,ncolmx,nvlev,32,
+cIM  .                "inst(X)",dtime,dtime)
+     .                "ave(X)",zcals(n),zout_isccp(n))
+         ENDIF !(1.EQ.0) THEN
+cIM 070905 END
+c        ENDIF !(n.EQ.3) THEN
+c       ENDIF !(1.EQ.0) THEN
+c
+c         print*,'n=',n,' avant histdef(..seed axe'
+          CALL histdef(nid_isccp, "seed"//verticaxe(n),
+     .                "seed axe"//verticaxe(n), "-",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+cIM  .                "inst(X)", dtime,dtime)
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+         ENDDO !n
+        ENDIF 
+        CALL histend(nid_isccp)
+c
+c$OMP END MASTER
+      ENDIF ! ok_isccp
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histREGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histREGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histREGDYN.h	(revision 984)
@@ -0,0 +1,127 @@
+!
+! $Header$
+!
+
+      IF (ok_regdyn) THEN
+      
+        if (is_sequential) then
+c
+cIM      PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_mth
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+c axe vertical pour les differents niveaux des histogrammes
+      DO iw=1, iwmax
+        zx_o500(iw)=wmin+(iw-1./2.)*pas_w
+      ENDDO
+
+         CALL histbeg("histREGDYN", kmaxm1,zx_tau, lmaxm1,zx_pc,
+     .                 1,kmaxm1,1,lmaxm1, itau_phy, zjulian, dtime, 
+     .                 nhoriRD, nid_regdyn)
+
+         CALL histvert(nid_regdyn, "omeganivs", "Omega levels", 
+     .                 "mb/day",
+     .                 iwmax, zx_o500, komega)
+c
+c   pour les champs instantannes, il faut mettre la meme valeur pour
+c   zout et zsto.
+c   dtime est passe par ailleurs a histbeg
+c
+c        zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn))
+c        zsto = zout
+c        print*,'zout,zsto=',zout,zsto
+c
+c stockage a chaque pas de temps de la physique
+c
+         zstophy = dtime
+cIM 020904      zstophy = dtime * nbapp_isccp
+
+c ecriture mensuelle
+c
+         zout = dtime * ecrit_mth
+cIM 020904      
+c        zout = dtime * ecrit_day
+c        zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn))
+
+c
+c Champs 3D:
+c
+c TROP
+         CALL histdef(nid_regdyn, "hw1", "Tropics Histogram ", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh1", "Nb of pixels Tropics Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht1",
+     &                "Total Nb pixels Tropics Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+c PAN
+         CALL histdef(nid_regdyn, "hw2", "North Pacific Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh2", "Nb of pixels North Pacific",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht2",
+     &                "Total Nb pixels North Pacific Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c CAL
+         CALL histdef(nid_regdyn, "hw3", "California Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh3", 
+     &                "Nb of pixels California Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht3",
+     &                "Total Nb pixels California Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c HAW
+         CALL histdef(nid_regdyn, "hw4", "Hawai Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh4", "Nb of pixels Hawai Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht4",
+     &                "Total Nb pixels Hawai Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c WAP
+         CALL histdef(nid_regdyn, "hw5", "Warm Pool Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh5", "Nb of pixels Warm Pool Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht5",
+     &                "Total Nb pixels Warm Pool Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+         CALL histend(nid_regdyn)
+	 
+	 endif ! is_sequential
+
+      endif ! ok_regdyn
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histday.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histday.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histday.h	(revision 984)
@@ -0,0 +1,649 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+
+c$OMP MASTER
+c
+       zstophy = dtime
+       zstoday= ecrit_day
+       zout = ecrit_day
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_day)
+
+         CALL histbeg_phy("histday",itau_phy, zjulian, dtime, 
+     .                    nhori, nid_day)
+
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+       IF(lev_histday.GE.1) THEN
+c
+         CALL histdef(nid_day, "phis", "Surface geop. height", "m2/s2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "contfracATM","% sfce ter+lic ","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "contfracOR","% sfce terre OR", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c Champs retires momentannement en attendant un hypothetique
+c debugage
+
+         CALL histdef(nid_day, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_day, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "plul", "Large-scale Precip.",
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "pluc", "Convective Precip.",
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "snowl", "Solid Large-scale Precip.",
+     .   "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF(1.EQ.0) THEN !snowc=0.
+         CALL histdef(nid_day, "snowc", "Solid Convective Precip.",
+     .   "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF !snowc=0.
+c
+         CALL histdef(nid_day, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstoday,zout)
+c
+         CALL histdef(nid_day, "q2m", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wind10max", "10-m wind speed max.",
+     .                "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "precip","Precipitation Totale liq+sol"
+     .                , "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "snowf", "Snow fall", "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_day, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "evap", "Evaporation", "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sols", "Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldq", "Cloud liquid water path", 
+     .                "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c  Champs dynamiques sur niveaux de pression
+c
+c        DO k=1, nlevENS
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb2=clevSTD(k)
+c        ENDIF
+c
+         IF(bb2.EQ."850".OR.bb2.EQ."700"
+     .   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_day, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_day, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+         IF(bb2.EQ."500") THEN
+c
+         CALL histdef(nid_day, "w"//bb2, "Vertical wind "//bb2//"mb",
+     .                "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_day,"phi"//bb2, "Geopotential "//bb2//"mb",
+     .                "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."500")
+c
+         ENDDO !nlevSTD
+c
+         CALL histdef(nid_day, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cape_max", "CAPE max.",
+     .                "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                capemaxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+         IF (OCEAN.EQ.'force ') THEN
+c
+          CALL histdef(nid_day, "lmt_bils", 
+     .         "Bilan au sol atmosphere forcee", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+          CALL histdef(nid_day, "slab_bils",
+     .                "Bilan au sol slab", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "tslab", "Slab SST ", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "seaice", "Slab seaice", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "siceh", "Slab seaice height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF !OCEAN.EQ.force/slab
+c
+         CALL histdef(nid_day, "fluxo",
+     .                "Flux turbulents ocean-atmosphere", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "fluxg",
+     .                "Flux ocean-glace de mer", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.1
+c
+      IF (lev_histday.GE.2) THEN
+c
+         CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2/K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.2
+c=================================================================
+      IF(lev_histday.GE.3) THEN
+c=================================================================
+c   INITIALISATION DES CHAMPS 3D
+c=================================================================
+c=================================================================
+c=================================================================
+c Champs 3D:
+c
+         CALL histdef(nid_day, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c=================================================================
+c   FIN INITIALISATION DES CHAMPS 3D
+c=================================================================
+      ENDIF !  lev_histday.GE.3
+c
+      IF (lev_histday.GE.4) THEN
+c=================================================================
+c
+c   INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+c
+         CALL histdef(nid_day, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWupTOAclr",
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWupSFCclr",
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWdnTOAclr",
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWdnSFCclr",
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM AMMA-MIP
+         CALL histdef(nid_day, "LWdnSFC",
+     .                "LW down at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "LWupSFC",
+     .                "LW down at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM     IF (iflag_con.GE.3) THEN 
+         CALL histdef(nid_day, "ptop",
+c    .                "Cld top pressure","mb",
+     .                "Cld top pressure (cf ISCCP simulator)","Pa",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+cIM     ENDIF !(iflag_con.GE.3) THEN 
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c   INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c=================================================================
+c
+         CALL histdef(nid_day, "tter", "Surface Temperature ter", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tlic", "Surface Temperature lic", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "toce", "Surface Temperature oce", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tsic", "Surface Temperature sic", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter", "Temp.tere 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mlic", "Temp.lic 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2moce", "Temp.oce 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2msic", "Temp.sic 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter_min", "Temp.terre 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter_max", "Temp.terre 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "u10mter", "Vent zonal ter 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10mlic", "Vent zonal lic 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10moce", "Vent zonal oce 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10msic", "Vent zonal sic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10mter", "Vent meridien ter 10m", 
+     .                "m/s", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10mlic", "Vent meridien lic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10moce", "Vent meridien oce 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10msic", "Vent meridien sic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_day, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_day, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress "//clnsurf(nsrf),"Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_day, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "rugs_"//clnsurf(nsrf), 
+     $         "Rugosite "//clnsurf(nsrf), "m",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+         END DO 
+C           
+c=================================================================
+c
+c   FIN INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+      ENDIF !lev_histday.GE.4
+c
+      IF(lev_histday.GE.5) THEN !lev_histday.GE.5
+c
+c rajout sorties F. Aires
+         CALL histdef(nid_day, "tops0", "CS Solar rad. at TOA", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "topl0", "CS IR rad. at TOA", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sols0", "CS Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "soll0", "CS Net IR rad. at surface", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rneb", "Cloud fraction", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"meantaucld",
+     .                "ISCCP mean cloud optical thickness","1",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"cldtau","Cloud optical thickness","1",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"cldemi","Cloud optical emissivity","1",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM rajout AMMA-MIP
+c
+         CALL histdef(nid_day, "dtcon", "Convection dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "dqcon", "Convection dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rh2m", "Relative humidity at 2m", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "qsat2m", "Saturant humidity at 2m", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tpot", 
+     .                "Surface air potential temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tpote", 
+     .        "Surface air equivalent potential temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.5
+c=================================================================
+c
+         CALL histend(nid_day)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c=================================================================
+c$OMP END MASTER
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histday_seri.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histday_seri.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histday_seri.h	(revision 984)
@@ -0,0 +1,131 @@
+c
+c $Header$
+c
+cym Ne fonctionnera pas en mode parallele
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+c
+       zstophy = dtime
+       zout = ecrit_day
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+         imin_debut=1 
+         nbpti=1
+         jmin_debut=1 
+         nbptj=1
+c
+         CALL histbeg("histday_seri.nc", 
+     .                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 imin_debut,nbpti,jmin_debut,nbptj,
+     .                 itau_phy, zjulian, dtime,
+     .                 nhori, nid_day_seri)
+c
+         CALL histvert(nid_day_seri, "presnivs", 
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+         CALL histdef(nid_day_seri, "bilTOA", 
+     .                "Net radiation at model top", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "bils", 
+     .                "Net downward energy flux at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "ecin", 
+     .                "Total kinetic energy (per unit area)","J/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM 151004 BEG
+         IF(1.EQ.0) THEN
+c
+         CALL histdef(nid_day_seri, "momang", 
+     .               "Total relative angular momentum (per unit area)",
+     .               "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "frictor", 
+     .               "Friction torque (per unit area)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "mountor", 
+     .               "Mountain torque (per unit area)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF !(1.EQ.0) THEN
+c
+         CALL histdef(nid_day_seri, "momang", 
+     .               "Axial angular momentum (per unit area)",
+     .               "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "torsfc", 
+     .        "Total surface torque (including mountain torque)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM 151004 END        
+c
+         CALL histdef(nid_day_seri, "tamv", 
+     .                "Temperature (mass-weighted vert. ave)", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "psol", 
+     .                "Surface pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "evap", 
+     .                "Evaporation and sublimation (per unit area)", 
+     .                "kg/(m2*s)",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          call histdef(nid_day_seri, 
+c    .         "SnowFrac", 
+c    .         "Snow-covered area ", "%",  
+c    .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_day_seri, "snow_depth", 
+cIM 080904  .                "Snow Depth (water equivalent)", "m",
+cIM 191104  .                "Snow Depth (water equivalent)", "kg/m2",
+c    .                "Snow Mass", "kg/m2",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .               "ave(X)", zstophy,zout)
+c
+           call histdef(nid_day_seri, 
+     .         "tsol_"//clnsurf(is_oce), 
+     .         "SST over open (ice-free) ocean ", "K",  
+     .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+c=================================================================
+c
+         CALL histend(nid_day_seri)
+c
+c=================================================================
+      ENDIF ! fin de test sur type_run.EQ.AMIP
+      
+      ENDIF ! is_sequential
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histhf.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histhf.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histhf.h	(revision 984)
@@ -0,0 +1,402 @@
+!
+! $Header$
+!
+
+      IF (ok_hf) THEN
+c$OMP MASTER
+c
+       zstohf = ecrit_hf
+       zstophy = dtime
+       zstoday = ecrit_day
+       zout = ecrit_hf
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+cym         CALL histbeg("histhf", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_hf)
+
+         CALL histbeg_phy("histhf", itau_phy, zjulian, dtime, 
+     .                 nhori, nid_hf)
+
+         CALL histvert(nid_hf, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+         CALL histdef(nid_hf, "aireTER","Grid area CONT","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+         CALL histdef(nid_hf, "contfracATM","% sfce ter+lic ","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+         CALL histdef(nid_hf, "contfracOR","% sfce terre OR", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_hf, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "precip", "Precipitation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+cIM ENSEMBLES BEG
+         CALL histdef(nid_hf, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+          IF(bb2.EQ."500") THEN
+          CALL histdef(nid_hf, "phi"//bb2,
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+          ENDIF !bb2.EQ."500"
+         ENDDO !k=1, nlevSTD
+c
+      ENDIF !lev_histhf.GE.1
+c
+      IF(lev_histhf.GE.2) THEN
+c
+         CALL histdef(nid_hf, "cldt", "Total cloudiness", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "SWnetOR",
+     .                "Sfce net SW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "SWdownOR",
+     .                "Sfce incident SW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "LWdownOR",
+     .                "Sfce incident LW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+      ENDIF !lev_histhf.GE.2
+c
+cIM ENSEMBLES END
+c
+      IF(lev_histhf.GE.3) THEN
+c
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".or.bb2.EQ."700".OR.
+     $      bb2.EQ."500".or.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_hf, "t"//bb2,
+     .                 "Temperature "//bb2//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          IF(bb2.NE."500") THEN
+          CALL histdef(nid_hf, "phi"//bb2, 
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+          ENDIF
+c
+          CALL histdef(nid_hf, "q"//bb2,
+     .                 "Specific humidity "//bb2//"mb","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          CALL histdef(nid_hf, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          CALL histdef(nid_hf, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         ENDIF !IF(bb2.EQ."850".or.bb2.EQ."700".OR.
+c
+         ENDDO !nlevSTD
+c
+      ENDIF !lev_histhf.GE.3
+c
+      IF(lev_histhf.GE.4) THEN
+c
+cIM sorties hf 3D
+c
+#undef histhf3d
+#define histhf3d
+#ifdef histhf3d
+#include "ini_histhf3d.h"
+#endif
+      ENDIF !lev_histhf.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+        DO k=1, nlevSTD 
+c
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".or.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_hf, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb2.EQ."850".or.bb2.EQ."200"
+        ENDDO !k=1, nlevSTD
+c
+        CALL histdef(nid_hf, "topl", 
+     .       "Outgoing longwave radiation", "W/m2",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "precip","Total precipitation rate",
+     .       "kg/(s*m2)",iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .       "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "slp", 
+     .       "Mean sea-level pressure", "Pa",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "inst(X)", zstohf,zout)
+c
+cIM 280504 BEG
+      ENDIF !(lev_histhf.GE.1) THEN
+c
+      IF(lev_histhf.GE.2) THEN
+c
+        DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".OR.bb2.EQ."500") THEN
+c
+          CALL histdef(nid_hf, "t"//bb2,
+     .                 "Temperature "//bb2//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "q"//bb2,
+     .                 "Specific humidity "//bb2//"mb","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb2
+c
+         IF(bb2.EQ."500") THEN
+c
+          CALL histdef(nid_hf, "phi"//bb2,
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "w"//bb2,
+     .                 "Vertical motion "//bb2//"mb","Pa/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+         ENDIF !bb2.EQ."500"
+c
+         IF(bb3.EQ."50") THEN
+c
+          CALL histdef(nid_hf, "t"//bb3,
+     .                 "Temperature "//bb3//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "u"//bb3,
+     .                 "Zonal wind "//bb3//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "v"//bb3,
+     .                 "Meridional wind "//bb3//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb3
+c
+        ENDDO !k=1, nlevSTD
+c
+        CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "t2m", "Temperature 2m", "K",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "cldt", "Total cloudiness", "%",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "taux",
+     $         "Zonal wind stress","Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "tauy",
+     $         "Meridional wind stress ", "Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+cIM 090904  .                "ave(X)", zstohf,zout)
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+cIM 090904  .                "ave(X)", zstohf,zout)
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+c       CALL histdef(nid_hf, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf,"LWdnSFC","Down. IR rad. at surface",
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf,"LWupSFC","Upwd. IR rad. at surface",
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        DO k=1, nbteta
+         CALL histdef(nid_hf, "PV"//ctetaSTD(k),
+     $               "Vorticite potentielle "//ctetaSTD(k)//"K",
+     $               "1/(Pa*s)",iim,jj_nb,nhori, 1,1,1, -99,
+     $                 32, "inst(X)", zstohf,zout) 
+        ENDDO !k=1, nbteta
+c
+c planetary boundary layer height
+c
+c       ENDIF !1.EQ.0
+c
+      ENDIF !(lev_histhf.GE.2) THEN
+cIM 280504 END
+c
+      ENDIF !type_run
+c
+      CALL histend(nid_hf)
+c
+c$OMP END MASTER
+      ENDIF ! ok_hf
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histhf3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histhf3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histhf3d.h	(revision 984)
@@ -0,0 +1,51 @@
+c $Header$
+c
+c sorties hf 3d
+c
+        zstohf = ecrit_hf
+        zout = ecrit_hf
+c
+c       PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf
+c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+cym         CALL histbeg("histhf3d", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_hf3d)
+         CALL histbeg_phy("histhf3d", itau_phy, zjulian, dtime, 
+     .                 nhori, nid_hf3d)
+
+        CALL histvert(nid_hf3d, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+c Champs 3D:
+c
+        CALL histdef(nid_hf3d, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histend(nid_hf3d)
+c
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histins.h	(revision 984)
@@ -0,0 +1,292 @@
+!
+! $Header$
+!
+      IF (ok_instan) THEN
+c$OMP MASTER
+c
+          zsto = ecrit_ins
+          zout = ecrit_ins
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_ins)
+         CALL histbeg_phy("histins", itau_phy, zjulian, dtime,
+     .                 nhori, nid_ins)
+         write(*,*)'Inst ', itau_phy, zjulian
+         CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
+cIM    .                 klev, presnivs, nvert)
+     .                 klev, presnivs/100., nvert)
+c        call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
+c    .              klev, znivsig, nvert)
+c
+c
+         CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_ins, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+        CALL histdef(nid_ins, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "q2m", "Specific humidity 2m", "Kg/Kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+        CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c        CALL histdef(nid_ins, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "topl", "OLR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "evap", "Evaporation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_ins, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "tsol_"//clnsurf(nsrf), 
+     $         "Surface Temperature"//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+C
+           call histdef(nid_ins, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf),"Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional xind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "albe_"//clnsurf(nsrf), 
+     $         "Albedo "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "rugs_"//clnsurf(nsrf), 
+     $         "rugosite "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+CXXX
+         END DO 
+         CALL histdef(nid_ins, "rugs", "rugosity", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+c
+         CALL histdef(nid_ins, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+         CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c
+cIM cf. AM 081204 BEG
+c HBTM2
+         CALL histdef(nid_ins, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_pblt", "T at Boundary Layer Height", 
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_capCL", "Conv avlbl pot ener for 
+     .                ABL", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_cteiCL", "Instability criteria 
+     .                (ABL)", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs 3D:
+c
+         CALL histdef(nid_ins, "temp", "Temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "geop", "Geopotential height", "m",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+
+         CALL histend(nid_ins)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c$OMP END MASTER
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histmth.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histmth.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histmth.h	(revision 984)
@@ -0,0 +1,1852 @@
+c
+c $Header$
+c
+      IF (ok_mensuel) THEN
+c$OMP MASTER
+c
+       zstophy = dtime
+       zstomth = ecrit_mth                       !valeurs mensuelles "instantannees"
+       zstorad = dtime * FLOAT(radpas)    !variables stockees toutes les 2h
+       zstohf = ecrit_hf                         !variables stockees toutes les 6h
+       zout = ecrit_mth                          !frequence des sorties : 1 val. par mois
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_mth)
+
+           CALL histbeg_phy("histmth",itau_phy, zjulian, dtime, 
+     .                 nhori, nid_mth)
+     
+       write(*,*)'Mensuel ', itau_phy, zjulian
+         CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+         CALL histdef(nid_mth, "phis", 
+     .                "Surface geop. height", "m2/s2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_ter), 
+     .         "% "//clnsurf(is_ter), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_ter), 
+     .         "Fraction "//clnsurf(is_ter), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c ENSEMBLES BEG
+         CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c ENSEMBLES END
+         CALL histdef(nid_mth, "q2m", "Specific humidity 2m", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "qsurf", "Surface Air humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      if (.not. ok_veget) then
+         CALL histdef(nid_mth, "qsol", "Soil watter content", "mm",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "ndayrain", 
+     .                "Number of day with rain (liq+sol)", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstomth,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "snow", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "evap", "Evaporation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops0", "CS Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOAclr", 
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOAclr", 
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200", "SWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200clr", 
+     .                "SWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200", "SWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200clr", 
+     .                "SWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200", "LWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200clr", 
+     .                "LWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200", "LWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200clr", 
+     .                "LWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFCclr", 
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFCclr", 
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFCclr",
+     .                "CS Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFCclr",
+     .                "Down. CS IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting",
+     .                "W/m2",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqcalving","Ice Calving",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqfonte","Land ice melt",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+
+         DO nsrf = 1, nbsrf
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+         ENDDO
+c
+         DO nsrf = 1, nbsrf
+C
+          IF(nsrf.GT.2) THEN
+           call histdef(nid_mth, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+          ENDIF !nsrf.GT.2
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "flw_"//clnsurf(nsrf),
+     $         "LW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fsw_"//clnsurf(nsrf),
+     $         "SW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbils_"//clnsurf(nsrf),
+     $         "Bilan sol "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbilo_"//clnsurf(nsrf),
+     $         "Bilan eau "//clnsurf(nsrf), "kg/(m2*s)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+cIM 250105 BEG
+          IF(1.EQ.0) THEN
+C
+           call histdef(nid_mth, "evapour_"//clnsurf(nsrf),
+     $         "Evap*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "prepour_"//clnsurf(nsrf),
+     $         "Precip*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+          ENDIF !(1.EQ.0) THEN
+cIM 250105 END
+C
+         END DO
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cKE43
+      IF(iflag_con.GE.3) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !iflag_con .GE. 3
+c34EK
+cIM cf. AM 081204 BEG
+c34EK
+c HBTM2
+         CALL histdef(nid_mth, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_pblt", "t at Boundary Layer Height",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_capCL", "Conv avlbl pot ener 
+     .                for ABL", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_cteiCL", "Instability criteria 
+     .                (ABL)", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs interpolles sur des niveaux de pression
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_mth, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "w"//bb2,
+     .                 "Vertical wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "phi"//bb2,
+     .                 "Geopotential "//bb2//"mb","m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+        ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+       ENDDO
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+       CALL histdef(nid_mth, "fluxo",
+     .              "Flux turbulents ocean-atmosphere", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "fluxg",
+     .              "Flux turbulents ocean-glace de mer","W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "t_oce_sic",
+     .              "Temp. mixte oce-sic","K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       IF (OCEAN.EQ.'force ') THEN
+c
+        CALL histdef(nid_mth, "lmt_bils",
+     .       "Bilan au sol atmosphere forcee", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+        CALL histdef(nid_mth, "slab_bils",
+     .       "Bilan au sol Slab", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "tslab", "Slab SST ", "K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "seaice", "Slab seaice", "kg/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "siceh", "Slab seaice height", "m",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ENDIF
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+c
+c
+         CALL histdef(nid_mth,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "ppmv",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqphy", "Physics dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+        DO nsrf=1, nbsrf
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+	 ENDDO !nsrf=1, nbsrf
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.3
+c
+      IF(lev_histmth.GE.4) THEN
+c
+         CALL histdef(nid_mth, "clwcon", 
+     .                "Convective Cloud Liquid water content"
+     .                , "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "ducon", "Convection du", "m/s2",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqcon", "Convection dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlschr",
+     $     "Large-scale condensational heating rate", "K/s",iim,jj_nb
+     $     ,nhori, klev,1,klev,nvert, 32,"ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqvdf","Boundary-layer dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqeva","Reevaporation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth,"dqajs","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+         CALL histdef(nid_mth, "tau", "cloud opt thickness", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM1", "CCM1", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM2", "CCM2", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "cldemi", "emissivite IR", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_NAT", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AD", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AI", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AD", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_NAT", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+#endif
+#ifndef INCA
+         if (nqmax.GE.3) THEN
+           DO iq=3,nqmax
+           iiq=niadv(iq)
+             CALL histdef(nid_mth, tnom(iq), ttext(iiq), "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+           ENDDO
+         ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+         CALL histdef(nid_mth, "phis", "Surface geop. height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_ter), 
+     .         "% "//clnsurf(is_ter), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_ter), 
+     .         "Fraction "//clnsurf(is_ter), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_lic), 
+     .         "% "//clnsurf(is_lic), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_lic), 
+     .         "Fraction "//clnsurf(is_lic), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_sic),
+     .         "% "//clnsurf(is_sic), "%",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_sic),
+     .         "Fraction "//clnsurf(is_sic), "1",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bilTOA",
+     .                "Net radiation at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c
+c        CALL histdef(nid_mth, "tops01",
+c    .                "TOA reflected clear-sky shortwave 
+c    .                radiation (method 1)", "W/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtdia","dtdia","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtsw","dtsw","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtlw","dtlw","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtcon","dtcon","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtajs","dtajs","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtlsc","dtlsc","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dqdia","dqdia","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "duoli",
+     .         "duoli","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvoli",
+     .         "dvoli","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "ducon",
+     .         "ducon","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvcon",
+     .         "dvcon","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dutot",
+     .         "dutot","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvtot",
+     .         "dvtot","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c         CALL histdef(nid_mth, "cldtrue",
+c    .         "TRUE Cloud fraction ","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "inst(X)", zout,zout)
+c
+c         CALL histdef(nid_mth, "cldTOA",
+c    .         "Cloud amount (satellite view)","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+c         CALL histdef(nid_mth, "cldSFC",
+c    .         "Cloud amount (surface view)","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "GWDtaux",
+     .         "GWD induced Ewd wind stress","Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "GWDtauy",
+     .         "GWD induced Nwd wind stress","Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "q2m","Specific humidity 2m","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "qsurf","Surface Air humidity","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      if (.not. ok_veget) then
+         CALL histdef(nid_mth, "qsol", "Soil watter content", "mm",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "ndayrain", 
+     .                "Number of day with rain (liq+sol)", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstomth,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "snowf", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "evap", 
+     .                "Evaporation plus sublimation rate", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops0", "CS Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOAclr", 
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOAclr", 
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200", "SWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200clr", 
+     .                "SWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200", "SWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200clr", 
+     .                "SWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200", "LWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200clr", 
+     .                "LWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200", "LWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200clr", 
+     .                "LWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFCclr", 
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFCclr", 
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFCclr",
+     .                "CS Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFCclr",
+     .                "Down. CS IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting",
+     .                "W/m2",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqcalving","Ice Calving",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         DO nsrf = 1, nbsrf
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+         ENDDO
+c
+           call histdef(nid_mth, "pourc_"//clnsurf(is_oce), 
+     $         "% "//clnsurf(is_oce), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fract_"//clnsurf(is_oce), 
+     $         "Fraction "//clnsurf(is_oce), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "flw_"//clnsurf(nsrf),
+     $         "LW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fsw_"//clnsurf(nsrf),
+     $         "SW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbils_"//clnsurf(nsrf),
+     $         "Bilan sol "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbilo_"//clnsurf(nsrf),
+     $         "Bilan eau "//clnsurf(nsrf), "kg/(m2*s)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+cIM 250105 BEG
+          IF(1.EQ.0) THEN
+C
+           call histdef(nid_mth, "evapour_"//clnsurf(nsrf),
+     $         "Evap*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "prepour_"//clnsurf(nsrf),
+     $         "Precip*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+          ENDIF !(1.EQ.0) THEN
+cIM 250105 END
+C
+         END DO
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cKE43
+      IF(iflag_con.GE.3) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !iflag_con .GE. 3
+c34EK
+cIM cf. AM 081204 BEG
+c34EK
+c HBTM2
+         CALL histdef(nid_mth, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_pblt", "T at Boundary Layer Height",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth,"s_capCL","Conv avlbl pot ener for ABL",
+     .                "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth,"s_cteiCL","Instability criteria (ABL)",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs interpolles sur des niveaux de pression
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+       IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_mth, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "w"//bb2,
+     .                 "Vertical wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "phi"//bb2,
+     .                 "Geopotential "//bb2//"mb","m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."850".OR.bb2.EQ."700"
+c
+       ENDDO !nlevSTD
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+       CALL histdef(nid_mth, "fluxo",
+     .              "Flux turbulents ocean-atmosphere", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "fluxg",
+     .              "Flux turbulents ocean-glace de mer","W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "t_oce_sic",
+     .              "Temp. mixte oce-sic","K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       IF (OCEAN.EQ.'force ') THEN
+c
+        CALL histdef(nid_mth, "lmt_bils",
+     .       "Bilan au sol atmosphere forcee", "W/m2",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "ave(X)", zstophy,zout)
+c
+       ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+        CALL histdef(nid_mth, "slab_bils",
+     .              "Bilan au sol Slab", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "tslab", "Slab SST ", "K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "seaice", "Slab seaice", "kg/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "siceh", "Slab seaice height", "m",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ENDIF !OCEAN.EQ.slab/force
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+c
+c
+         CALL histdef(nid_mth,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "rneb", "Cloud fraction", "%",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "ppmv",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqphy","Physics dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+        DO nsrf=1, nbsrf
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Rugosite "//clnsurf(nsrf), "m",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+	 ENDDO !nsrf=1, nbsrf
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.3
+c
+      IF(lev_histmth.GE.4) THEN
+c
+         CALL histdef(nid_mth, "clwcon", 
+     .                "Convective Cloud Liquid water content"
+     .                , "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqdyn","Dynamics dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqcon","Convection dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlschr",
+     $       "Large-scale condensational heating rate", "K/s",
+     $       iim,jj_nb
+     $       ,nhori, klev,1,klev,nvert, 32,"ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqlsc","Condensation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqvdf","Boundary-layer dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dqeva","Reevaporation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "dqajs","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+         CALL histdef(nid_mth, "tau", "cloud opt thickness", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM1", "CCM1", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM2", "CCM2", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "cldemi", "emissivite IR", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_NAT", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AD", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AI", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_ZERO", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AER", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AD", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_NAT", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+#endif
+#ifndef INCA
+         if (nqmax.GE.3) THEN
+           DO iq=3,nqmax
+             iiq=niadv(iq)
+             CALL histdef(nid_mth, tnom(iq), ttext(iiq), "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+             ENDDO
+           ENDIF
+#endif
+
+      ENDIF !lev_histmth.GE.4
+c
+      ENDIF !type_run.EQ."CLIM".OR.type_run.EQ."ENSP")
+c
+         CALL histend(nid_mth)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c$OMP END MASTER
+      ENDIF ! fin de test sur ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histmthNMC.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histmthNMC.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histmthNMC.h	(revision 984)
@@ -0,0 +1,185 @@
+!
+! $Header$
+!
+      IF (ok_mensuel) THEN
+c
+c$OMP MASTER
+
+       zstophy = dtime
+       zstohf = ecrit_hf
+       zstomth = ecrit_mth
+       zout = ecrit_mth
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_nmc)
+
+         CALL histbeg_phy("histNMC",itau_phy, zjulian, dtime, 
+     .                 nhori, nid_nmc)
+c
+         CALL histvert(nid_nmc, "presnivs", "Vertical levels", "mb",
+     .                 nlevSTD, rlevSTD/100., nvert)
+ccc
+ccc Champs 3D interpolles sur des niveaux de pression du NMC
+ccc
+      IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+          CALL histdef(nid_nmc, "temp",
+     .                 "Temperature","K",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "phi",
+     .                "Geopotential", "m",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "q",
+     .                 "Specific humidity","kg/kg",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "rh",
+     .                 "Relative humidity", "%",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "u",
+     .                 "Zonal wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "v",
+     .                 "Meridional wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+c             sur les niveaux du NMC et on somme & moyenne
+c             toutes les 6 heures par des routines undefSTD et
+c             moy_undefSTD pour eliminer les valeurs "undef"
+c             de la moyenne mensuelle
+c ======> le "inst(X)" ci-dessous est par consequence factice !
+c
+          CALL histdef(nid_nmc, "temp",
+     .                 "Temperature","K",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "phi",
+     .                "Geopotential ", "m",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "q",
+     .                 "Specific humidity","kg/kg",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "rh",
+     .                 "Relative humidity", "%",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "u",
+     .                 "Zonal wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "v",
+     .                 "Meridional wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "w",
+     .                 "Vertical motion","Pa/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+c             sur les niveaux du NMC et on somme & moyenne
+c             toutes les 6 heures par des routines undefSTD et
+c             moy_undefSTD pour eliminer les valeurs "undef"
+c             de la moyenne mensuelle
+c ======> le "inst(X)" ci-dessus est par consequence factice !
+c
+c
+          CALL histdef(nid_nmc, "psbg",
+     .         "Pressure sfce below ground","%",
+     .         iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "uv",
+     .         "uv ",
+     .         "m2/s2",iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vq",
+     .         "vq ",
+     .         "m/s * (kg/kg)",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vT",
+     .         "vT ", 
+     .         "mK/s",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "wq",
+     .         "wq ", 
+     .         "(Pa/s)*(kg/kg)",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vphi",
+     .         "vphi ", 
+     .         "m2/s",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "wT",
+     .         "wT ", 
+     .         "K*Pa/s",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "uxu",
+     .         "u2 ", 
+     .         "m2/s2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vxv",
+     .         "v2 ", 
+     .         "m2/s2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "TxT",
+     .         "T2 ", 
+     .         "K2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+      ENDIF !(type_run.EQ."AMIP")
+
+         CALL histend(nid_nmc)
+c
+c$OMP END MASTER
+
+      ENDIF ! fin de test sur ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_histrac.h	(revision 984)
@@ -0,0 +1,130 @@
+!
+! $Header$
+!
+#ifndef INCA
+c$OMP MASTER 
+         CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = xlon(i+1)
+cym            zx_lon(i,jjm+1) = xlon(i+1)
+cym         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlat,zx_lat)
+cym         CALL histbeg("histrac", iim,zx_lon(:,1), jjm+1,zx_lat(1,:),
+cym     .                 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys,
+cym     .                 nhori, nid_tra)
+         CALL histbeg_phy("histrac", itau_phy, zjulian, pdtphys,
+     .                 nhori, nid_tra)
+         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+
+
+
+         zsto = pdtphys
+!         zout = pdtphys * ecrit_tra
+         zout = ecrit_tra
+c
+         CALL histdef(nid_tra, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+c
+         CALL histdef(nid_tra, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+         DO it=1,nqmax
+C champ 2D
+         iq=it+2
+         iiq=niadv(iq)
+         CALL histdef(nid_tra, tnom(iq), ttext(iiq), "U/kga",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         if (lessivage) THEN
+         CALL histdef(nid_tra, "fl"//tnom(iq),"Flux "//ttext(iiq),
+     .              "U/m2/s",iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+         endif
+
+c---Ajout Olivia
+         CALL histdef(nid_tra, "d_tr_th_"//tnom(iq),
+     .	              "tendance thermique"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "d_tr_cv_"//tnom(iq),
+     .	              "tendance convection"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "d_tr_cl_"//tnom(iq),
+     .	              "tendance couche limite"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c---fin Olivia	 
+
+         ENDDO
+
+         CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+
+         CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf1", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf2", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf3", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf4", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol1", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol2", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol3", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst",  zout,zout)
+         CALL histdef(nid_tra, "ftsol4", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "pplay", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zout,zout)
+         CALL histdef(nid_tra, "t", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zout,zout)
+         CALL histdef(nid_tra, "mfu", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "mfd", "flux u decen","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_u", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_d", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_d", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_u", "flux u decen","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "coefh", "turbulent coef","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+c
+         CALL histend(nid_tra)
+         ndex2d = 0
+         ndex3d = 0
+         ndex = 0
+c$OMP END MASTER
+#endif
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_paramLMDZ_phy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_paramLMDZ_phy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_paramLMDZ_phy.h	(revision 984)
@@ -0,0 +1,365 @@
+cym    Non implemente en mode parallele
+
+       IF (is_sequential) THEN  
+c
+       zstophy = dtime
+       zout = ecrit_day
+c
+       idayref = day_ref
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+       DO i = 1, iim
+         zx_lon(i,1) = rlon(i+1)
+         zx_lon(i,jjmp1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+       CALL histbeg("paramLMDZ_phy.nc", 
+     .                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,1,1,1,
+     .                 itau_phy, zjulian, dtime,
+     .                 nhori, nid_ctesGCM)
+c
+c Variables type caractere : plusieurs valeurs possibles
+c
+       CALL histdef(nid_ctesGCM, "ocean", 
+     .        "Type ocean utilise: 1=force, 2=slab, 3=couple",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_slab_sicOBS",
+     ."ok_slab_sicOBS= 1: glace de mer observee, =0: gl.mer calculee 
+     . par le slab", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "type_run",
+     .        "Type run: 1= CLIM ou ENSP, 2= AMIP ou CFMI",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c Variables logiques (1=true, 0=false)
+c
+       CALL histdef(nid_ctesGCM, "ok_veget", 
+     .        "Type de modele de vegetation: 1=ORCHIDEE, 0=bucket",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_journe", 
+     .        "Creation du fichier histday: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_mensuel", 
+     .        "Creation du fichier histmth: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_instan", 
+     .        "Creation du fichier histins: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_ade", 
+     .        "Aerosol direct effect: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_aie", 
+     .        "Aerosol indirect effect: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "bl95_b0", 
+     .        "Parameter in CDNC-maer link (Boucher&Lohmann 1995)",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "bl95_b1", 
+     .        "Parameter in CDNC-maer link (Boucher&Lohmann 1995)",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ip_ebil_phy", 
+     .                "Niveau sortie diags bilan energie cote physique",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_ecc", 
+     .                "Excentricite","-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_peri", 
+     .                "Equinoxe","-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_incl", 
+     .                "Inclinaison","deg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "solaire", 
+     .                "Constante solaire","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "co2_ppm", 
+     .                "Concentration du CO2", "ppm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CH4_ppb", 
+     .                "Concentration du CH4", "ppb",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "N2O_ppb",
+     .                "Concentration du N2O", "ppb",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CFC11_ppt",
+     .                "Concentration du CFC11", "ppt",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CFC12_ppt",
+     .                "Concentration du CFC12", "ppt",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "epmax",
+     .                "Efficacite precip", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_adj_ema",
+     .                "ok_adj_ema: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_clw",
+     .                "iflag_clw", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_lc_lsc",
+     .                "cld_lc_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_lc_con",
+     .                "cld_lc_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_tau_lsc",
+     .                "cld_tau_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_tau_con",
+     .                "cld_tau_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ffallv_lsc",
+     .                "ffallv_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ffallv_con",
+     .                "ffallv_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "coef_eva",
+     .                "coef_eva", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "reevap_ice",
+     .                "reevap_ice: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_cldcon",
+     .                "iflag_cldcon", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_pdf",
+     .                "iflag_pdf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "fact_cldcon",
+     .                "fact_cldcon", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "facttemps",
+     .                "facttemps", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_newmicro",
+     .                "Nouvelle micro-physique: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ratqsbas",
+     .                "ratqsbas", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ratqshaut",
+     .                "ratqshaut", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_froid",
+     .                "rad_froid", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_chau1",
+     .                "rad_chau1", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_chau2",
+     .                "rad_chau2", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "top_height",
+     .                "top_height", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "overlap",
+     .                "overlap", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cdmmax",
+     .                "cdmmax", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cdhmax",
+     .                "cdhmax", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ksta",
+     .                "ksta", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ksta_ter",
+     .                "ksta_ter", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_kzmin",
+     .                "ok_kzmin: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_pbl",
+     .                "iflag_pbl", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histhf",
+     .                "lev_histhf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histday",
+     .                "lev_histday", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histmth",
+     .                "lev_histmth", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_isccp",
+     .                "Creation fichier histISCCP: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lonmin_ins",
+     .                "lonmin_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lonmax_ins",
+     .                "lonmax_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "latmin_ins",
+     .                "latmin_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "latmax_ins",
+     .                "latmax_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_ins",
+     .                "ecrit_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_hf",
+     .                "ecrit_hf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_day",
+     .                "ecrit_day", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_mth",
+     .                "ecrit_mth", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_tra",
+     .                "ecrit_tra", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_reg",
+     .                "ecrit_reg", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "freq_ISCCP",
+     .                "freq_ISCCP", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_ISCCP",
+     .                "ecrit_ISCCP", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c=================================================================
+c
+       CALL histend(nid_ctesGCM)
+       
+       ENDIF ! is_sequential
+c
+c=================================================================
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ini_undefSTD.F	(revision 984)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+
+      SUBROUTINE ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $           tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Initialisation - a des frequences differentes : 
+c
+c 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
+c    calculees a partir des valeurs "instantannees" de la physique
+c
+c 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
+c    toutes les 6 heures
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c              ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c              ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+c
+cym #include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym #include "dimphy.h"
+c variables Input/Output
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime
+      REAL ecrit_day,ecrit_mth
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+c
+c variables Output
+      REAL tnondef(klon,klevSTD,nout)
+      REAL tsumSTD(klon,klevSTD,nout)
+c
+c initialisation variables journalieres en debut de journee
+c
+      IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.1.) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,1)=0.
+         tsumSTD(i,k,1)=0.
+        ENDDO !i
+       ENDDO !k
+      ENDIF
+c
+c initialisation variables mensuelles (calculees a chaque pas de temps) 
+c en debut de mois : nout=2
+c
+      IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.1.) THEN
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,2)=0.
+         tsumSTD(i,k,2)=0.
+        ENDDO !i
+       ENDDO !k
+c
+c initialisation variables mensuelles - runs type Amip - (calculees toutes les 6h)
+c en debut de mois : nout = 3
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,3)=0.
+         tsumSTD(i,k,3)=0.
+        ENDDO !i
+       ENDDO !k
+c
+      ENDIF
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/inifis.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/inifis.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/inifis.F	(revision 984)
@@ -0,0 +1,73 @@
+!
+! $Header$
+!
+      SUBROUTINE inifis(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,
+     $           prad,pg,pr,pcpp)
+      use dimphy
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon)
+      INTEGER pdayref
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon
+         STOP
+      ENDIF
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/iniphysiq.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/iniphysiq.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/iniphysiq.F	(revision 984)
@@ -0,0 +1,99 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE iniphysiq(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,pcu,pcv,
+     $           prad,pg,pr,pcpp)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE comgeomphy
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "comgeomphy.h"
+#include "YOMCST.h"
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon_glo)
+      REAL pcu(klon_glo),pcv(klon_glo)
+      INTEGER pdayref
+      INTEGER :: ibegin,iend,offset
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon_glo) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon_glo
+         STOP
+      ENDIF
+c$OMP PARALLEL PRIVATE(ibegin,iend) 
+c$OMP+         SHARED(parea,pcu,pcv,plon,plat)
+      
+      offset=klon_mpi_begin-1
+      airephy(1:klon_omp)=parea(offset+klon_omp_begin:
+     &                          offset+klon_omp_end)
+      cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end)
+      cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end)
+      rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end)
+      rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end)
+
+      call suphec
+
+c$OMP END PARALLEL
+
+      print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ'
+      print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...'
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/init_phys_lmdz.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/init_phys_lmdz.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/init_phys_lmdz.F90	(revision 984)
@@ -0,0 +1,24 @@
+!
+!$Header$
+!
+SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nbtr,nb_proc,distrib)
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE dimphy, ONLY : Init_dimphy
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: llm
+    INTEGER,INTENT(in) :: nbtr
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+
+    CALL Init_grid_phy_lmdz(iim,jjp1,llm)
+    CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL Init_dimphy(klon_omp,nbp_lev,nbtr)
+!$OMP END PARALLEL
+ 
+END SUBROUTINE Init_Phys_lmdz  
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/initphysto.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/initphysto.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/initphysto.F	(revision 984)
@@ -0,0 +1,304 @@
+!
+! $Header$
+!
+C
+C
+      subroutine initphysto
+     .  (infile,
+     .  rlon, rlat, tstep,t_ops,t_wrt,nq,fileid)
+       
+       USE dimphy
+       USE mod_phys_lmdz_para
+       USE IOIPSL
+       USE iophy
+      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   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 "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+cym#include "dimphy.h"
+
+C   Arguments
+      character*(*) infile
+      integer*4 nhoriid, i
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq,l
+      real nivsigs(llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, idayref
+      logical ok_sync
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+C
+      REAL rlon(klon), rlat(klon)
+
+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 = 0
+	
+cym	CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjm+1) = rlon(i+1)
+cym         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+
+
+      call histbeg_phy(infile,tau0, zjulian, tstep,
+     .                 nhoriid, fileid)
+
+c$OMP MASTER	
+C  Appel a histvert pour la grille verticale
+C
+	DO l=1,llm
+            nivsigs(l)=float(l)
+         ENDDO
+
+	write(*,*) 'avant histvert ds initphysto'
+
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+	write(*,*) 'apres histvert ds initphysto'
+
+       CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+c
+	write(*,*) 'apres phis ds initphysto'
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         write(*,*) 'apres aire ds initphysto'
+
+cym     Attention dtime et istphy ne sont pas �rit ---> a �iminer ?
+         CALL histdef(fileid, "dtime", "tps phys ", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	 CALL histdef(fileid, "istphy", "tps stock", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+C T 
+C
+      call histdef(fileid, 't', 'Temperature', 'K',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres t ds initphysto'
+C mfu 
+C
+      call histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres mfu ds initphysto'
+C
+C mfd 
+C
+      call histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_u 
+C
+      call histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+               write(*,*) 'apres en_u ds initphysto'
+C
+C de_u 
+C
+      call histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_d 
+C
+      call histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C de_d 
+C
+      call histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c coefh frac_impa,frac_nucl
+	
+	call histdef(fileid, "coefh", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c abderrahmane le 16 09 02
+        call histdef(fileid, "fm_th", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+        call histdef(fileid, "en_th", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+c fin aj
+	
+	write(*,*) 'apres coefh ds initphysto'	
+
+	call histdef(fileid, 'frac_impa', ' ', ' ',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+	
+	call histdef(fileid, 'frac_nucl', ' ', ' ',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c
+c pyu1
+c
+      CALL histdef(fileid, "pyu1", " ", " ",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+
+c
+c pyv1
+c
+	CALL histdef(fileid, "pyv1", " ", " ",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'apres pyv1 ds initphysto'
+c
+c ftsol1
+c
+	call histdef(fileid, "ftsol1", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol2
+c
+        call histdef(fileid, "ftsol2", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol3
+c
+        call histdef(fileid, "ftsol3", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol4
+c
+        call histdef(fileid, "ftsol4", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c rain
+c
+        call histdef(fileid, "rain", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf1
+c
+	call histdef(fileid, "psrf1", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c psrf2
+c
+        call histdef(fileid, "psrf2", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf3
+c
+        call histdef(fileid, "psrf3", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf4
+c
+        call histdef(fileid, "psrf4", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'avant histend ds initphysto'	
+
+      call histend(fileid)
+c     if (ok_sync) call histsync(fileid)
+      if (ok_sync) call histsync
+c$OMP END MASTER
+	
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/initrrnpb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/initrrnpb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/initrrnpb.F	(revision 984)
@@ -0,0 +1,124 @@
+!
+! $Header$
+!
+      SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: initialisation des constantes des traceurs
+CAA Revison pour le controle avec la temperature du sol
+cAA
+CAA   it = 1 radon ss controle de ts
+cAA   it = 2 plomb ss controle de ts  
+c======================================================================
+c Arguments:
+c nbtr------input-I- nombre de vrais traceurs (sans l'eau)
+c ftsol-------input-R- Temperature du sol (Kelvin)
+c pctsrf-----input-R-  Nature de sol (pourcentage de sol)
+c masktr---output-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----output-R- Flux surfacique de production dans le sol
+c hsoltr---output-R- Epaisseur du reservoir de sol
+c tautr----output-R- Constante de decroissance du traceur
+c vdeptr---output-R- Vitesse de depot sec dans la couche Brownienne
+c scavtr---output-R- Coefficient de lessivage
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+c======================================================================
+C
+      INTEGER i, it
+      REAL pctsrf(klon,nbsrf) !Pourcentage de sol (f(nature du sol))
+      REAL ftsol(klon,nbsrf)  ! Temperature du sol pour le controle Rn
+c                             ! le cas echeant
+      REAL masktr(klon,nbtr)  ! Masque de l'echange avec la surface
+c                                 (possible => 1 )
+      REAL fshtr(klon,nbtr)  ! Flux surfacique dans le reservoir de sol
+      REAL hsoltr(nbtr)      ! Epaisseur equivalente du reservoir de sol
+      REAL tautr(nbtr)       ! Constante de decroissance radioactive
+      REAL vdeptr(nbtr)      ! Vitesse de depot sec dans la couche Brownienne
+      REAL scavtr(nbtr)      ! Coefficient de lessivage
+      REAL s
+C
+      WRITE(*,'(''PASSAGE initrrnpb ...'',$)')
+      print*,'nbtr= ',nbtr
+      print*,'nbsrf= ',nbsrf
+      print*,'klon= ',klon
+C
+C Puis les initialisation specifiques a chaque traceur (pour le moment, Rn222)
+C
+C
+C Radon it = 1
+c
+      IF ( nbtr .LE. 0 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 1
+      s = 1.E4  !  Source: atome par m2
+      hsoltr(it) = 0.1      ! Hauteur equivalente du reservoir : 
+c                              1 m * porosite 0.1
+      tautr(it) = 4.765E5  ! Decroissance du radon, secondes
+cAA
+c      tautr(it) = 4.765E55  ! Decroissance du radon,infinie
+cAA
+      vdeptr(it) = 0. ! Pas de depot sec pour le radon
+      scavtr(it) = 0. ! Pas de lessivage pour le radon
+
+      print*, '-------------- SOURCE DU RADON ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+
+      DO i = 1,klon
+        masktr(i,it) = 0.
+        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
+        fshtr(i,it) = s * masktr(i,it)
+
+cAA
+cAA quelques tests
+cAA POur l'instant le pctsrf(i,3) = 1.0 
+cAA lorsqu'il ya de la terre mias ne prend aucune autre valeur
+cAA il n'est donc pas necessaire de multiplier fshtr par pctsrf
+cAA 
+c       print*, '------------------------------------------ '
+c        print*, 'masktr(',i,it,')= ',masktr(i,it)
+c        print*, 'fshtr(',i,it,')= ',fshtr(i,it)
+c        print*, 'pctsrf(',i,',1)= ',pctsrf(i,1)
+c        print*, 'pctsrf(',i,',2)= ',pctsrf(i,2)
+c        print*, 'pctsrf(',i,',3)= ',pctsrf(i,3)
+c        print*, 'pctsrf(',i,',4)= ',pctsrf(i,4)
+c        print*, 's = ',s
+c        print*, '------------------------------------------ '
+
+      END DO
+C
+C 210Pb it = 2
+C
+      IF ( nbtr .LE. 1 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 2
+      s = 0. !  Pas de source !!!
+      hsoltr(it) = 10.     ! Hauteur equivalente du reservoir 
+c                              a partir duquel le
+c                              depot Brownien a lieu
+      tautr(it) = 1.028E9 ! Decroissance du Pb210, secondes
+      vdeptr(it) = 1.E-3 ! 1 mm/s pour le 210Pb
+      scavtr(it) =  .5   ! Lessivage du Pb210
+      DO i = 1,klon
+        masktr(i,it) = 1. ! Le depot sec peut avoir lieu partout
+        fshtr(i,it) = s * masktr(i,it)
+      END DO
+      print*, '-------------- SOURCE DU PLOMB ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir : ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+c
+      WRITE(*,*) 'initialisation rnpb ok'
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/interfoce_lim.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/interfoce_lim.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/interfoce_lim.F90	(revision 984)
@@ -0,0 +1,289 @@
+!
+! $Header$
+!
+SUBROUTINE interfoce_lim(itime, dtime, jour, &
+     knon, knindex, &
+     debut,  &
+     lmt_sst_p, pctsrf_new_p)
+  
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  
+  IMPLICIT NONE
+  
+  INCLUDE "indicesol.h"
+  INCLUDE "netcdf.inc"
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst_p      SST lues dans le fichier de CL
+!   pctsrf_new-p   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+!****************************************************************************************
+  INTEGER, INTENT(IN)                       :: itime
+  INTEGER, INTENT(IN)                       :: jour
+  INTEGER, INTENT(IN)                       :: knon
+  INTEGER, DIMENSION(klon_loc), INTENT(IN)  :: knindex
+  REAL   , INTENT(IN)                       :: dtime
+  LOGICAL, INTENT(IN)                       :: debut
+  
+! Parametres de sortie
+!****************************************************************************************
+  REAL, INTENT(OUT), DIMENSION(klon_loc)       :: lmt_sst_p
+  REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p
+
+
+! Variables locales avec l'attribut SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+  INTEGER,SAVE                              :: lmt_pas   
+  !$OMP THREADPRIVATE(lmt_pas)
+! pour indiquer que le jour a lire est deja lu pour une surface precedente
+  LOGICAL,SAVE                              :: deja_lu   
+  !$OMP THREADPRIVATE(deja_lu)
+  INTEGER,SAVE                              :: jour_lu 
+  !$OMP THREADPRIVATE(jour_lu)
+  CHARACTER (len = 20),SAVE                 :: fich ='limit.nc'
+  !$OMP THREADPRIVATE(fich)
+  LOGICAL, SAVE                             :: newlmt = .TRUE.
+  !$OMP THREADPRIVATE(newlmt)
+  LOGICAL, SAVE                             :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:)    :: sst_lu_p
+  !$OMP THREADPRIVATE(sst_lu_p)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:,:)  :: pct_tmp_p
+  !$OMP THREADPRIVATE(pct_tmp_p)
+
+! Variables locales 
+!****************************************************************************************
+  INTEGER                                   :: nid, nvarid
+  INTEGER                                   :: ii
+  INTEGER                                   :: ierr
+  INTEGER, DIMENSION(2)                     :: start, epais
+  CHARACTER (len = 20)                      :: modname = 'interfoce_lim'
+  CHARACTER (len = 80)                      :: abort_message
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pctsrf_new
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pct_tmp
+  REAL, DIMENSION(klon_glo)                 :: sst_lu
+  REAL, DIMENSION(klon_glo)                 :: nat_lu
+!
+! Fin declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! Start calculation
+!
+!****************************************************************************************
+  IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN
+     lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+     jour_lu = jour - 1
+     ALLOCATE(sst_lu_p(klon_loc))
+     ALLOCATE(pct_tmp_p(klon_loc,nbsrf))
+  ENDIF
+  
+  IF ((jour - jour_lu) /= 0) deja_lu = .FALSE.
+  
+  IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
+  IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime
+
+!****************************************************************************************
+! Ouverture et lecture du fichier pour le master process si c'est le bon moment
+!
+!****************************************************************************************
+! Tester d'abord si c'est le moment de lire le fichier
+  IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN
+
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+
+        fich = TRIM(fich)
+        ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+           abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+
+        ! La tranche de donnees a lire:
+
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+        IF (newlmt) THEN
+           !
+           ! Fraction "ocean" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FOCE> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FOCE>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glace de mer" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FSIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FSIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FTER> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FTER>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glacier terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FLIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FLIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+        ELSE  ! on en est toujours a rnatur
+           ! 
+           ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <NAT> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu)
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu)
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <NAT>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+!
+! Remplissage des fractions de surface
+! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
+! 
+           pct_tmp = 0.0
+           DO ii = 1, klon_glo
+              pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1.
+           ENDDO
+
+!
+!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
+!
+           pctsrf_new = pct_tmp
+           pctsrf_new (:,2)= pct_tmp (:,1)
+           pctsrf_new (:,1)= pct_tmp (:,2)
+           pct_tmp = pctsrf_new 
+        ENDIF ! fin test sur newlmt
+!
+! Lecture SST
+!
+        ierr = NF_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Le champ <SST> est absent'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu)
+#else
+        ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu)
+#endif
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Lecture echouee pour <SST>'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+          
+!****************************************************************************************
+! Fin de lecture, fermeture de fichier
+!
+!****************************************************************************************
+        ierr = NF_CLOSE(nid)
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+!****************************************************************************************
+! Distribue les variables sur tous les processus
+!
+!****************************************************************************************
+     CALL Scatter(sst_lu,sst_lu_p)
+     CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
+     CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
+     deja_lu = .TRUE.
+     jour_lu = jour
+  ENDIF
+
+!****************************************************************************************
+! Recopie des variables dans les champs de sortie
+!
+!****************************************************************************************
+  lmt_sst_p = 999999999.
+  
+  DO ii = 1, knon
+     lmt_sst_p(ii) = sst_lu_p(knindex(ii))
+  ENDDO
+  
+  DO ii=1,klon_loc
+     pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
+     pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
+  ENDDO
+  
+  
+END SUBROUTINE interfoce_lim
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/iophy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/iophy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/iophy.F90	(revision 984)
@@ -0,0 +1,183 @@
+module iophy
+  
+  REAL,private,allocatable,dimension(:,:),save :: tmp_tab2d
+  REAL,private,allocatable,dimension(:,:,:),save :: tmp_tab3d
+  INTEGER,private,allocatable,dimension(:),save :: ndex2d
+  INTEGER,private,allocatable,dimension(:),save :: ndex3d
+  REAL,private,allocatable,dimension(:),save :: io_lat
+  REAL,private,allocatable,dimension(:),save :: io_lon
+  INTEGER, save :: phys_domain_id
+  
+  INTERFACE histwrite_phy
+    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
+  END INTERFACE 
+
+contains
+
+  subroutine init_iophy(lat,lon)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  implicit none
+  include 'dimensions.h'   
+    real,dimension(iim),intent(in) :: lon
+    real,dimension(jjm+1),intent(in) :: lat
+
+    INTEGER,DIMENSION(2) :: ddid
+    INTEGER,DIMENSION(2) :: dsg
+    INTEGER,DIMENSION(2) :: dsl
+    INTEGER,DIMENSION(2) :: dpf
+    INTEGER,DIMENSION(2) :: dpl
+    INTEGER,DIMENSION(2) :: dhs
+    INTEGER,DIMENSION(2) :: dhe 
+
+!$OMP MASTER  
+    allocate(io_lat(jjm+1))
+    io_lat(:)=lat(:)
+    allocate(io_lon(iim))
+    io_lon(:)=lon(:)
+    allocate(tmp_tab2d(iim,jj_nb))
+    allocate(tmp_tab3d(iim,jj_nb,klev))
+    allocate(ndex2d(iim*jj_nb))
+    allocate(ndex3d(iim*jj_nb*klev))
+    ndex2d(:)=0
+    ndex3d(:)=0
+    
+    ddid=(/ 1,2 /)
+    dsg=(/ iim, jjm+1 /)
+    dsl=(/ iim, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',phys_domain_id)
+
+!$OMP END MASTER
+      
+  end subroutine init_iophy
+  
+  subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  use write_field
+  implicit none
+  include 'dimensions.h'
+    
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau0
+    real,intent(in) :: zjulian
+    real,intent(in) :: dtime
+    integer,intent(out) :: nhori
+    integer,intent(out) :: nid_day
+
+!$OMP MASTER    
+    if (is_sequential) then
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
+    else
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
+    endif
+!$OMP END MASTER
+  
+  end subroutine histbeg_phy
+  
+  subroutine histwrite2d_phy(nid,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  implicit none
+  include 'dimensions.h'
+    
+    integer,intent(in) :: nid
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(klon),intent(in) :: field
+    
+    REAL,dimension(klon_mpi) :: buffer_omp
+    
+    CALL Gather_omp(field,buffer_omp)    
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,tmp_tab2d)
+    CALL histwrite(nid,name,itau,tmp_tab2d,iim*jj_nb,ndex2d)
+!$OMP END MASTER    
+  end subroutine histwrite2d_phy
+  
+  subroutine histwrite3d_phy(nid,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+
+  use ioipsl
+  implicit none
+  include 'dimensions.h'
+    
+    integer,intent(in) :: nid
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(klon,klev),intent(in) :: field
+
+    REAL,dimension(klon_mpi,klev) :: buffer_omp
+    
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,tmp_tab3d)
+    CALL histwrite(nid,name,itau,tmp_tab3d,iim*jj_nb*klev,ndex3d)
+!$OMP END MASTER    
+  end subroutine histwrite3d_phy
+  
+  
+!  subroutine phy2dyn(field_phy,field_dyn,nlev)
+!  USE dimphy_old
+!  implicit none
+!  include 'dimensions.h'
+!  
+!    real,dimension(klon_mpi,nlev),intent(in) :: field_phy
+!    real,dimension(iim,jjphy_nb,nlev),intent(out) :: field_dyn
+!    integer,intent(in) :: nlev
+!    
+!    integer :: next
+!    integer :: j,l
+!    
+!      do l=1,nlev
+!        	
+!	if (jjphy_begin==jjphy_end) then
+!	  field_dyn(:,1,l)=0.
+!	  field_dyn(iiphy_begin:iiphy_end,1,l)=field_phy(1:klon_mpi,l)
+!	else
+!	
+!	 if (jjphy_begin==1) then
+!	    field_dyn(:,1,l)=field_phy(1,l)
+!	    next=2
+!	 else
+!	   field_dyn(:,1,l)=0.
+!	   next=iim-iiphy_begin+2
+!	   field_dyn(iiphy_begin:iim,1,l)=field_phy(1:next-1,l)   
+!	 endif
+!	
+!	  do j=2,jjphy_nb-1
+!	    field_dyn(:,j,l)=field_phy(next:next+iim-1,l)
+!	    next=next+iim
+!	  enddo
+!	  
+!	  if (jjphy_end==jjm+1) then
+!             field_dyn(:,jjphy_nb,l)=field_phy(klon_mpi,l)
+!	  else
+!	   field_dyn(:,jjphy_nb,l)=0.
+!	   field_dyn(1:iiphy_end,jjphy_nb,l)=field_phy(next:next+iiphy_end-1,l)   
+!	  endif
+!	  
+!	endif
+!     
+!     enddo
+!	 
+!    end subroutine phy2dyn	    
+  
+	  
+end module iophy
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/isccp_cloud_types.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/isccp_cloud_types.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/isccp_cloud_types.F	(revision 984)
@@ -0,0 +1,1668 @@
+!
+! $Header$
+!
+      SUBROUTINE ISCCP_CLOUD_TYPES(
+     &     debug,
+     &     debugcol,
+     &     npoints,
+     &     sunlit,
+     &     nlev,
+     &     ncol,
+     &     seed,
+     &     pfull,
+     &     phalf,
+     &     qv,
+     &     cc,
+     &     conv,
+     &     dtau_s,
+     &     dtau_c,
+     &     top_height,
+     &     overlap,
+     &     tautab,
+     &     invtau,
+     &     skt,
+     &     emsfc_lw,
+     &     at,dem_s,dem_c,
+     &     fq_isccp,
+     &     totalcldarea,
+     &     meanptop,
+     &     meantaucld,
+     &     boxtau,
+     &     boxptop
+     &)
+	
+
+! Copyright Steve Klein and Mark Webb 2002 - all rights reserved.
+!
+! This code is available without charge with the following conditions:
+!
+!  1. The code is available for scientific purposes and is not for 
+!     commercial use.
+!  2. Any improvements you make to the code should be made available 
+!     to the to the authors for incorporation into a future release.
+!  3. The code should not be used in any way that brings the authors 
+!     or their employers into disrepute.
+
+      implicit none
+
+!     NOTE:   the maximum number of levels and columns is set by
+!             the following parameter statement
+
+      INTEGER ncolprint
+      
+!     -----
+!     Input 
+!     -----
+
+      INTEGER npoints                   !  number of model points in the horizontal
+c      PARAMETER(npoints=6722)
+      INTEGER nlev                      !  number of model levels in column
+      INTEGER ncol                      !  number of subcolumns
+
+      INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
+
+      INTEGER seed(npoints)             !  seed value for random number generator
+c                                       !  ( see Numerical Recipes Chapter 7)
+c                                       !  It is recommended that the seed is set
+c                                       !  to a different value for each model
+c                                       !  gridbox it is called on, as it is 
+c          				!  possible that the choice of the samec 
+c					!  seed value every time may introduce some
+c					!  statistical bias in the results, particularly
+c					!  for low values of NCOL.
+c
+      REAL pfull(npoints,nlev)	      	!  pressure of full model levels (Pascals)
+c                                        !  pfull(npoints,1)    is    top level of model
+c                                        !  pfull(npoints,nlev) is bottom level of model
+
+      REAL phalf(npoints,nlev+1)        !  pressure of half model levels (Pascals)
+c                                        !  phalf(npoints,1)    is    top       of model
+c                                        !  phalf(npoints,nlev+1) is the surface pressure
+
+      REAL qv(npoints,nlev)             !  water vapor specific humidity (kg vapor/ kg air)
+c                                        !         on full model levels
+
+      REAL cc(npoints,nlev)             !  input cloud cover in each model level (fraction) 
+c                                        !  NOTE:  This is the HORIZONTAL area of each
+c                                        !         grid box covered by clouds
+
+      REAL conv(npoints,nlev)           !  input convective cloud cover in each model level (fraction) 
+c                                        !  NOTE:  This is the HORIZONTAL area of each
+c                                        !         grid box covered by convective clouds
+
+      REAL dtau_s(npoints,nlev)         !  mean 0.67 micron optical depth of stratiform
+c					!  clouds in each model level
+c                                        !  NOTE:  this the cloud optical depth of only the
+c                                        !         cloudy part of the grid box, it is not weighted
+c                                        !         with the 0 cloud optical depth of the clear
+c                                        !         part of the grid box
+
+      REAL dtau_c(npoints,nlev)         !  mean 0.67 micron optical depth of convective
+c					!  clouds in each
+c                                        !  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
+c                                        !  infrared brightness temperature and the visible
+c					!  optical depth to adjust cloud top pressure. Note
+c					!  that this calculation is most appropriate to compare
+c					!  to ISCCP data during sunlit hours.
+c                                        !  2 = do not adjust top height, that is cloud top
+c                                        !  pressure is the actual cloud top pressure
+c                                        !  in the model
+c					!  3 = adjust top height using only the computed
+c					!  infrared brightness temperature. Note that this
+c					!  calculation is most appropriate to compare to ISCCP
+c					!  IR only algortihm (i.e. you can compare to nighttime
+c					!  ISCCP data with this option)
+
+      REAL tautab(0:255)                !  ISCCP table for converting count value to 
+c                                        !  optical thickness
+
+      INTEGER invtau(-20:45000)         !  ISCCP table for converting optical thickness 
+c                                        !  to count value
+!
+!     The following input variables are used only if top_height = 1 or top_height = 3
+!
+      REAL skt(npoints)                 !  skin Temperature (K)
+      REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)                                            
+      REAL at(npoints,nlev)                   !  temperature in each model level (K)
+      REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
+c					!  clouds in each
+c                                        !  model level.  Same note applies as in dtau_s.
+      REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
+c					!  clouds in each
+c                                        !  model level.  Same note applies as in dtau_s.
+cIM reg.dyn BEG
+      REAL t1, t2
+!     REAL w(npoints)                   !vertical wind at 500 hPa
+!     LOGICAL pct_ocean(npoints)        !TRUE if oceanic point, FALSE otherway
+!     INTEGER iw(npoints) , nw
+!     REAL wmin, pas_w
+!     INTEGER k, l, iwmx
+!     PARAMETER(wmin=-100.,pas_w=10.,iwmx=30)
+!     REAL fq_dynreg(7,7,iwmx)
+!     REAL nfq_dynreg(7,7,iwmx) 
+!     LOGICAL pctj(7,7,iwmx)
+cIM reg.dyn END
+!     ------
+!     Output
+!     ------
+
+      REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
+c                                        !  each of the 49 ISCCP D level cloud types
+
+      REAL totalcldarea(npoints)        !  the fraction of model grid box columns
+c                                        !  with cloud somewhere in them.  This should
+c					!  equal the sum over all entries of fq_isccp
+	
+	
+c      ! The following three means are averages over the cloudy areas only.  If no
+c      ! clouds are in grid box all three quantities should equal zero.	
+					
+      REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
+c                                        !  in cloud top pressure.
+					
+      REAL meantaucld(npoints)          !  mean optical thickness 
+c                                        !  linear averaging in albedo performed.
+      
+      REAL boxtau(npoints,ncol)         !  optical thickness in each column
+      
+      REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
+					
+															
+!
+!     ------
+!     Working variables added when program updated to mimic Mark Webb's PV-Wave code
+!     ------
+
+      REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
+c					! Equivalent of BOX in original version, but
+c					! indexed by column then row, rather than
+c					! by row then column
+
+      REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction)
+c                                        ! with extra layer of zeroes on top
+c                                        ! in this version this just contains the values input
+c                                        ! from cc but with an extra level
+      REAL cca(npoints,nlev)         ! convective cloud cover in each model level (fraction)
+c                                        ! from conv 
+
+      REAL threshold(npoints,ncol)   ! pointer to position in gridbox
+      REAL maxocc(npoints,ncol)      ! Flag for max overlapped conv cld
+      REAL maxosc(npoints,ncol)      ! Flag for max overlapped strat cld
+
+      REAL boxpos(npoints,ncol)      ! ordered pointer to position in gridbox
+
+      REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold
+c                                        ! is chosen
+
+      REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave 
+c					!  emissivity in part of
+c					!  gridbox under consideration
+
+      REAL ran(npoints)   	        ! vector of random numbers
+      REAL ptrop(npoints)
+      REAL attrop(npoints)
+      REAL attropmin (npoints)
+      REAL atmax(npoints)
+      REAL atmin(npoints)
+      REAL btcmin(npoints)
+      REAL transmax(npoints)
+
+      INTEGER i,j,ilev,ibox,itrop(npoints)
+      INTEGER ipres(npoints)
+      INTEGER itau(npoints),ilev2
+      INTEGER acc(nlev,ncol)
+      INTEGER match(npoints,nlev-1)
+      INTEGER nmatch(npoints)
+      INTEGER levmatch(npoints,ncol)
+      
+c      !variables needed for water vapor continuum absorption
+      real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
+      real taumin(npoints)
+      real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
+      real press(npoints), dpress(npoints), atmden(npoints)
+      real rvh20(npoints), wk(npoints), rhoave(npoints)
+      real rh20s(npoints), rfrgn(npoints)
+      real tmpexp(npoints),tauwv(npoints)
+      
+      character*1 cchar(6),cchar_realtops(6)
+      integer icycle
+      REAL tau(npoints,ncol)
+      LOGICAL box_cloudy(npoints,ncol)
+      REAL tb(npoints,ncol)
+      REAL ptop(npoints,ncol)
+      REAL emcld(npoints,ncol)
+      REAL fluxtop(npoints,ncol)
+      REAL trans_layers_above(npoints,ncol)
+      real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
+      real meanalbedocld(npoints) 
+      REAL albedocld(npoints,ncol)
+      real boxarea
+      integer debug       ! set to non-zero value to print out inputs
+c			  ! with step debug
+      integer debugcol    ! set to non-zero value to print out column
+c			  ! decomposition with step debugcol
+
+      integer index1(npoints),num1,jj
+      real rec2p13,tauchk
+
+      character*10 ftn09
+      
+      DATA isccp_taumin / 0.3 /
+      DATA cchar / ' ','-','1','+','I','+'/
+      DATA cchar_realtops / ' ',' ','1','1','I','I'/
+
+      tauchk = -1.*log(0.9999999)
+      rec2p13=1./2.13
+
+      ncolprint=0
+
+cIM
+c     PRINT*,' isccp_cloud_types npoints=',npoints
+c
+c      if ( debug.ne.0 ) then
+c          j=1
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write(6,'(a10)') 'debug='
+c          write(6,'(8I10)') debug
+c          write(6,'(a10)') 'debugcol='
+c          write(6,'(8I10)') debugcol
+c          write(6,'(a10)') 'npoints='
+c          write(6,'(8I10)') npoints
+c          write(6,'(a10)') 'nlev='
+c          write(6,'(8I10)') nlev
+c          write(6,'(a10)') 'ncol='
+c          write(6,'(8I10)') ncol
+c          write(6,'(a10)') 'top_height='
+c          write(6,'(8I10)') top_height
+c          write(6,'(a10)') 'overlap='
+c          write(6,'(8I10)') overlap
+c          write(6,'(a10)') 'emsfc_lw='
+c          write(6,'(8f10.2)') emsfc_lw
+c          write(6,'(a10)') 'tautab='
+c          write(6,'(8f10.2)') tautab
+c          write(6,'(a10)') 'invtau(1:100)='
+c          write(6,'(8i10)') (invtau(i),i=1,100)
+c	  do j=1,npoints,debug
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write(6,'(a10)') 'sunlit='
+c          write(6,'(8I10)') sunlit(j)
+c          write(6,'(a10)') 'seed='
+c          write(6,'(8I10)') seed(j)
+c          write(6,'(a10)') 'pfull='
+c          write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
+c          write(6,'(a10)') 'phalf='
+c          write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
+c          write(6,'(a10)') 'qv='
+c          write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
+c          write(6,'(a10)') 'cc='
+c          write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
+c          write(6,'(a10)') 'conv='
+c          write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dtau_s='
+c          write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dtau_c='
+c          write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
+c          write(6,'(a10)') 'skt='
+c          write(6,'(8f10.2)') skt(j)
+c          write(6,'(a10)') 'at='
+c          write(6,'(8f10.2)') (at(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dem_s='
+c          write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dem_c='
+c          write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev)
+c	  enddo
+c      endif
+
+!     ---------------------------------------------------!
+
+!     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
+
+!     assign 2d cca array using 1d input array conv
+
+      do ilev=1,nlev
+cIM pas besoin        do ibox=1,ncol
+          do j=1,npoints
+            cca(j,ilev)=conv(j,ilev)
+          enddo
+cIM        enddo
+      enddo
+
+cIM
+!     do j=1, iwmx
+!     do l=1, 7
+!     do k=1, 7
+!       fq_dynreg(k,l,j) =0. 
+!       nfq_dynreg(k,l,j) =0. 
+!      enddo !k
+!     enddo !l
+!     enddo !j
+cIM
+cIM
+c      if (ncolprint.ne.0) then
+c	do j=1,npoints,1000
+c        write(6,'(a10)') 'j='
+c        write(6,'(8I10)') j
+c        write (6,'(a)') 'seed:'
+c        write (6,'(I3.2)') seed(j)
+
+c        write (6,'(a)') 'tca_pp_rev:'
+c        write (6,'(8f5.2)') 
+c     &   ((tca(j,ilev)),
+c     &      ilev=1,nlev)
+
+c        write (6,'(a)') 'cca_pp_rev:'
+c        write (6,'(8f5.2)') 
+c     &   ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev)
+c	enddo
+c      endif
+
+      if (top_height .eq. 1 .or. top_height .eq. 3) then 
+
+      do j=1,npoints 
+          ptrop(j)=5000.
+          atmin(j) = 400.
+          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
+           if (at(j,ilev) .gt. atmax(j)) atmax(j)=at(j,ilev)
+           if (at(j,ilev) .lt. atmin(j)) atmin(j)=at(j,ilev)
+        enddo
+12    continue
+
+      end if
+
+!     -----------------------------------------------------!
+
+!     ---------------------------------------------------!
+
+cIM
+c     do 13 ilev=1,nlev
+cnum1=0
+c       do j=1,npoints
+c           if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  ' error = cloud fraction less than zero'
+c	write(6,*) ' or '
+c               write(6,*)  ' error = cloud fraction greater than 1'
+c	write(6,*) 'value at point ',j,' is ',cc(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+cnum1=0
+c       do j=1,npoints
+c           if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud fraction less than zero'
+c	write(6,*) ' or '
+c               write(6,*)  
+c    &           ' error = convective cloud fraction greater than 1'
+c	write(6,*) 'value at point ',j,' is ',conv(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dtau_s(j,ilev) .lt. 0.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = stratiform cloud opt. depth less than zero'
+c	write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+cnum1=0
+c       do j=1,npoints
+c           if (dtau_c(j,ilev) .lt. 0.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud opt. depth less than zero'
+c	write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = stratiform cloud emissivity less than zero'
+c	write(6,*)'or'
+c               write(6,*)  
+c    &           ' error = stratiform cloud emissivity greater than 1'
+c	write(6,*) 'value at point ',j,' is ',dem_s(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud emissivity less than zero'
+c	write(6,*)'or'
+c               write(6,*)  
+c    &           ' error = convective cloud emissivity greater than 1'
+c               write (6,*) 
+c    &          'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev) 
+c               STOP
+c       enddo
+c13    continue
+
+
+      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 ibox=1,ncol
+        do ilev=1,nlev
+          do j=1,npoints
+	    frac_out(j,ibox,ilev)=0.0
+          enddo
+        enddo
+      enddo
+
+cIM
+c      if (ncolprint.ne.0) then
+c        write (6,'(a)') 'frac_out_pp_rev:'
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(8f5.2)') 
+c     &     ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
+
+c          enddo
+c        write (6,'(a)') 'ncol:'
+c        write (6,'(I3)') ncol
+c      endif
+c      if (ncolprint.ne.0) then
+c        write (6,'(a)') 'last_frac_pp:'
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(8f5.2)') (tca(j,0))
+c          enddo
+c      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
+                call ran0_vec(npoints,seed,ran)
+	        ! select random pixels from the non-convective
+	        ! part the gridbox ( some will be converted into
+	        ! convective pixels below )
+                do j=1,npoints
+                  threshold(j,ibox)=
+     &            cca(j,ilev)+(1-cca(j,ilev))*ran(j)
+                enddo
+              enddo
+            ENDIF
+cIM
+c            IF (ncolprint.ne.0) then
+c              write (6,'(a)') 'threshold_nsf2:'
+c                do j=1,npoints,1000
+c                write(6,'(a10)') 'j='
+c                write(6,'(8I10)') j
+c                write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+c                enddo
+c            ENDIF
+        ENDIF
+
+c        IF (ncolprint.ne.0) then
+c            write (6,'(a)') 'ilev:'
+c            write (6,'(I2)') ilev
+c        ENDIF
+
+        DO ibox=1,ncol
+
+          ! All versions
+          do j=1,npoints
+            if (boxpos(j,ibox).le.cca(j,ilev)) then
+cIM REAL           maxocc(j,ibox) = 1
+              maxocc(j,ibox) = 1.0
+            else
+cIM REAL           maxocc(j,ibox) = 0
+              maxocc(j,ibox) = 0.0
+            end if
+          enddo
+
+          ! Max overlap
+          if (overlap.eq.1) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=cca(j,ilev)
+cIM REAL           maxosc(j,ibox)=1
+              maxosc(j,ibox)=1.0
+            enddo
+          endif
+
+          ! Random overlap
+          if (overlap.eq.2) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=cca(j,ilev)
+cIM REAL           maxosc(j,ibox)=0
+              maxosc(j,ibox)=0.0
+            enddo
+          endif
+
+          ! Max/Random overlap
+          if (overlap.eq.3) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=max(cca(j,ilev),
+     &          min(tca(j,ilev-1),tca(j,ilev)))
+              if (threshold(j,ibox)
+     &          .lt.min(tca(j,ilev-1),tca(j,ilev))
+     &          .and.(threshold(j,ibox).gt.cca(j,ilev))) then
+cIM REAL                maxosc(j,ibox)= 1
+                   maxosc(j,ibox)= 1.0
+              else
+cIM REAL                 maxosc(j,ibox)= 0
+                   maxosc(j,ibox)= 0.0
+              end if
+            enddo
+          endif
+    
+          ! Reset threshold 
+          call ran0_vec(npoints,seed,ran)
+	   
+          do j=1,npoints
+            threshold(j,ibox)=
+              !if max overlapped conv cloud
+     &        maxocc(j,ibox) * (                                       
+     &            boxpos(j,ibox)                                               
+     &        ) +                                                      
+              !else
+     &        (1-maxocc(j,ibox)) * (                                   
+                  !if max overlapped strat cloud
+     &            (maxosc(j,ibox)) * (                                 
+                      !threshold=boxpos
+     &                threshold(j,ibox)                                        
+     &            ) +                                                  
+                  !else
+     &            (1-maxosc(j,ibox)) * (                               
+                      !threshold_min=random[thrmin,1]
+     &                threshold_min(j,ibox)+
+     &                  (1-threshold_min(j,ibox))*ran(j)  
+     &           ) 
+     &        )
+          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
+cIM REAL             frac_out(j,ibox,ilev)=1
+               frac_out(j,ibox,ilev)=1.0
+               else
+cIM REAL             frac_out(j,ibox,ilev)=0
+               frac_out(j,ibox,ilev)=0.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.cca(j,ilev)) then
+                    ! = 2 IF threshold le cca(j)
+cIM REAL                  frac_out(j,ibox,ilev) = 2 
+                    frac_out(j,ibox,ilev) = 2.0 
+                else
+                    ! = the same IF NOT threshold le cca(j) 
+                    frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev)
+                end if
+             enddo
+           ENDDO
+
+!         Set last_frac to tca at this level, so as to be tca 
+!         from last level next time round
+
+cIM
+c          if (ncolprint.ne.0) then
+
+c            do j=1,npoints ,1000
+c            write(6,'(a10)') 'j='
+c            write(6,'(8I10)') j
+c            write (6,'(a)') 'last_frac:'
+c            write (6,'(8f5.2)') (tca(j,ilev-1))
+    
+c            write (6,'(a)') 'cca:'
+c            write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'max_overlap_cc:'
+c            write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'max_overlap_sc:'
+c            write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'threshold_min_nsf2:'
+c            write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'threshold_nsf2:'
+c            write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'frac_out_pp_rev:'
+c            write (6,'(8f5.2)') 
+c     &       ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+c	    enddo
+c          endif
+
+200   CONTINUE    !loop over nlev
+
+!
+!     ---------------------------------------------------!
+
+      
+!
+!     ---------------------------------------------------!
+!     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)=0.
+	    boxptop(j,ibox)=0.
+	    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 
+cIM REAL              if (frac_out(j,ibox,ilev).eq.1) then
+                 if (frac_out(j,ibox,ilev).eq.1.0) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_s(j,ilev)
+                 endif
+cIM REAL              if (frac_out(j,ibox,ilev).eq.2) then
+                 if (frac_out(j,ibox,ilev).eq.2.0) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_c(j,ilev)
+                 end if
+              enddo
+            enddo ! ibox
+      enddo ! ilev
+cIM
+c          if (ncolprint.ne.0) then
+
+c              do j=1,npoints ,1000
+c                write(6,'(a10)') 'j='
+c                write(6,'(8I10)') j
+c                write(6,'(i2,1X,8(f7.2,1X))') 
+c     &          ilev,
+c     &          (tau(j,ibox),ibox=1,ncolprint)
+c              enddo
+c          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.
+cIM
+c        if (ncolprint .ne. 0) 
+c     &         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
+cIM
+c               if (ncolprint .ne. 0) then
+c               do j=1,npoints ,1000
+c               write(6,'(a10)') 'j='
+c               write(6,'(8I10)') j
+c               write(6,'(i2,1X,3(f8.3,3X))') ilev,
+c     &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
+c     &           tauwv(j),dem_wv(j,ilev)
+c               enddo
+c	       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 
+cIM  
+c            if (ncolprint.ne.0) then
+c             do j=1,npoints ,1000
+c              write(6,'(a10)') 'j='
+c              write(6,'(8I10)') j
+c              write (6,'(a)') 'ilev:'
+c              write (6,'(I2)') ilev
+    
+c              write (6,'(a)') 
+c     &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
+c              write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
+c     &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
+c             enddo   
+c            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)
+        enddo
+
+cIM
+c        if (ncolprint.ne.0) then
+c        do j=1,npoints ,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(a)') 'id:'
+c          write (6,'(a)') 'surface'
+
+c          write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
+c          write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j),
+c     &      100.*fluxtop_clrsky(j),
+c     &       trans_layers_above_clrsky(j)
+c        enddo
+c	endif
+    
+
+        !
+        !           END OF CLEAR SKY CALCULATION
+        !
+        !----------------------------------------------------------------
+
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c        do j=1,npoints ,1000
+c            write(6,'(a10)') 'j='
+c            write(6,'(8I10)') j
+c            write (6,'(a)') 'ts:'
+c            write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'ta_rev:'
+c            write (6,'(8f7.2)') 
+c     &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+
+c        enddo
+c        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
+cIM REAL             if (frac_out(j,ibox,ilev).eq.1) then
+                if (frac_out(j,ibox,ilev).eq.1.0) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
+cIM REAL             else if (frac_out(j,ibox,ilev).eq.2) then
+                else if (frac_out(j,ibox,ilev).eq.2.0) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
+                else
+                dem(j,ibox)=  dem_wv(j,ilev)
+                end if
+                
+
+                ! increase TOA flux by flux emitted from layer
+	        ! times total transmittance in layers above
+
+                fluxtop(j,ibox) = fluxtop(j,ibox) 
+     &            + dem(j,ibox) * bb(j)
+     &            * trans_layers_above(j,ibox) 
+            
+                ! update trans_layers_above with transmissivity
+	        ! from this layer for next time around loop
+
+                trans_layers_above(j,ibox)=
+     &            trans_layers_above(j,ibox)*(1.-dem(j,ibox))
+
+              enddo ! j
+            enddo ! ibox
+
+cIM
+c            if (ncolprint.ne.0) then
+c              do j=1,npoints,1000
+c              write (6,'(a)') 'ilev:'
+c              write (6,'(I2)') ilev
+    
+c              write(6,'(a10)') 'j='
+c              write(6,'(8I10)') j
+c              write (6,'(a)') 'emiss_layer:'
+c              write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
+        
+c              write (6,'(a)') '100.*bb(j):'
+c              write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+        
+c              write (6,'(a)') '100.*f:'
+c              write (6,'(8f7.2)') 
+c     &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+        
+c              write (6,'(a)') 'total_trans:'
+c              write (6,'(8f7.2)') 
+c     &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
+c	      enddo
+c          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
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c          do j=1,npoints ,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(a)') 'id:'
+c          write (6,'(a)') 'surface'
+
+c          write (6,'(a)') 'emiss_layer:'
+c          write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') '100.*bb(j):'
+c          write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+    
+c          write (6,'(a)') '100.*f:'
+c          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+c          end do
+c	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
+                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) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
+            end if
+          enddo ! j
+        enddo ! ibox
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+
+c          write (6,'(a)') 'attrop:'
+c          write (6,'(8f7.2)') (attrop(j))
+    
+c          write (6,'(a)') 'btcmin:'
+c          write (6,'(8f7.2)') (btcmin(j))
+    
+c          write (6,'(a)') 'fluxtop_clrsky*100:'
+c          write (6,'(8f7.2)') 
+c     &      (100.*fluxtop_clrsky(j))
+
+c          write (6,'(a)') '100.*f_adj:'
+c          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'transmax:'
+c          write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'tau:'
+c          write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'emcld:'
+c          write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_trans:'
+c          write (6,'(8f7.2)') 
+c     &	  (trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_emiss:'
+c          write (6,'(8f7.2)') 
+c     &	  (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_trans:'
+c          write (6,'(8f7.2)') 
+c     &	  (trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'ppout:'
+c          write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+c          enddo ! j
+c	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 ilev=1,nlev-1
+            !cdir nodep
+            do j=1,npoints 
+              if ((at(j,ilev)   .ge. tb(j,ibox) .and. 
+     &          at(j,ilev+1) .lt. tb(j,ibox)) .or.
+     &          (at(j,ilev) .le. tb(j,ibox) .and. 
+     &          at(j,ilev+1) .gt. tb(j,ibox))) then 
+   
+                nmatch(j)=nmatch(j)+1
+                if(abs(at(j,ilev)-tb(j,ibox)) .lt.
+     &            abs(at(j,ilev+1)-tb(j,ibox))) then
+                  match(j,nmatch(j))=ilev
+                else
+                  match(j,nmatch(j))=ilev+1
+                end if
+              end if                        
+            enddo
+29        continue
+
+          do j=1,npoints 
+            if (nmatch(j) .ge. 1) then
+              ptop(j,ibox)=pfull(j,match(j,nmatch(j)))
+              levmatch(j,ibox)=match(j,nmatch(j))   
+            else
+              if (tb(j,ibox) .lt. atmin(j)) then
+                ptop(j,ibox)=ptrop(j)
+                levmatch(j,ibox)=itrop(j)
+              end if
+              if (tb(j,ibox) .gt. 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. )
+cIM  &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
+     &           .and.(frac_out(j,ibox,ilev) .ne. 0.0)) then
+                ptop(j,ibox)=pfull(j,ilev)
+	        levmatch(j,ibox)=ilev
+              end if
+            end do
+          end do
+        end if                            
+          
+        do j=1,npoints
+          if (tau(j,ibox) .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 ! 
+             fq_isccp(j,ilev,ilev2)=0.
+        enddo
+38    continue
+
+      !reset variables need for averaging cloud properties
+      do j=1,npoints 
+        totalcldarea(j) = 0.
+        meanalbedocld(j) = 0.
+        meanptop(j) = 0.
+        meantaucld(j) = 0.
+      enddo ! j
+
+      boxarea = 1./real(ncol)
+     
+              !determine optical depth category
+cIM       do 39 j=1,npoints
+cIM       do ibox=1,ncol
+        do 39 ibox=1,ncol
+          do j=1,npoints
+
+cIM
+c         CALL CPU_time(t1)
+cIM
+
+          if (tau(j,ibox) .gt. (tauchk            )
+     &      .and. ptop(j,ibox) .gt. 0.) then
+              box_cloudy(j,ibox)=.true.
+          endif
+
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF tau t2 - t1',t2 - t1
+
+c         CALL CPU_time(t1)
+cIM
+
+          if (box_cloudy(j,ibox)) then
+
+              ! totalcldarea always diagnosed day or night
+              totalcldarea(j) = totalcldarea(j) + boxarea
+
+              if (sunlit(j).eq.1) then
+
+                ! tau diagnostics only with sunlight
+
+                boxtau(j,ibox) = tau(j,ibox)
+
+                !convert optical thickness to albedo
+  	        albedocld(j,ibox)
+     &            =real(invtau(min(nint(100.*tau(j,ibox)),45000)))
+	    
+                !contribute to averaging
+	        meanalbedocld(j) = meanalbedocld(j) 
+     &            +albedocld(j,ibox)*boxarea
+
+            endif
+
+          endif
+          
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF box_cloudy t2 - t1',t2 - t1
+          
+c         CALL CPU_time(t1)
+cIM BEG 
+cIM           !convert ptop to millibars
+              ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+cIM           !save for output cloud top pressure and optical thickness
+              boxptop(j,ibox) = ptop(j,ibox)
+cIM END
+
+cIM BEG
+              !reset itau(j), ipres(j)
+              itau(j) = 0
+              ipres(j) = 0
+
+              if (tau(j,ibox) .lt. isccp_taumin) then
+                  itau(j)=1
+              else if (tau(j,ibox) .ge. isccp_taumin
+     &                                    
+     &          .and. tau(j,ibox) .lt. 1.3) then
+                itau(j)=2
+              else if (tau(j,ibox) .ge. 1.3 
+     &          .and. tau(j,ibox) .lt. 3.6) then
+                itau(j)=3
+              else if (tau(j,ibox) .ge. 3.6 
+     &          .and. tau(j,ibox) .lt. 9.4) then
+                  itau(j)=4
+              else if (tau(j,ibox) .ge. 9.4 
+     &          .and. tau(j,ibox) .lt. 23.) then
+                  itau(j)=5
+              else if (tau(j,ibox) .ge. 23. 
+     &          .and. tau(j,ibox) .lt. 60.) then
+                  itau(j)=6
+              else if (tau(j,ibox) .ge. 60.) then
+                  itau(j)=7
+              end if
+
+              !determine cloud top pressure category
+              if (    ptop(j,ibox) .gt. 0.  
+     &          .and.ptop(j,ibox) .lt. 180.) then
+                  ipres(j)=1
+              else if(ptop(j,ibox) .ge. 180.
+     &          .and.ptop(j,ibox) .lt. 310.) then
+                  ipres(j)=2
+              else if(ptop(j,ibox) .ge. 310.
+     &          .and.ptop(j,ibox) .lt. 440.) then
+                  ipres(j)=3
+              else if(ptop(j,ibox) .ge. 440.
+     &          .and.ptop(j,ibox) .lt. 560.) then
+                  ipres(j)=4
+              else if(ptop(j,ibox) .ge. 560.
+     &          .and.ptop(j,ibox) .lt. 680.) then
+                  ipres(j)=5
+              else if(ptop(j,ibox) .ge. 680.
+     &          .and.ptop(j,ibox) .lt. 800.) then
+                  ipres(j)=6
+              else if(ptop(j,ibox) .ge. 800.) then
+                  ipres(j)=7
+              end if 
+cIM END
+
+          if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
+
+cIM         !convert ptop to millibars
+cIM           ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+cIM         !save for output cloud top pressure and optical thickness
+cIM             boxptop(j,ibox) = ptop(j,ibox)
+    
+            if (box_cloudy(j,ibox)) then
+	    
+              meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
+
+cIM             !reset itau(j), ipres(j)
+cIM           itau(j) = 0
+cIM           ipres(j) = 0
+
+c             if (tau(j,ibox) .lt. isccp_taumin) then
+c                 itau(j)=1
+c             else if (tau(j,ibox) .ge. isccp_taumin
+c    &                                    
+c    &          .and. tau(j,ibox) .lt. 1.3) then
+c               itau(j)=2
+c             else if (tau(j,ibox) .ge. 1.3 
+c    &          .and. tau(j,ibox) .lt. 3.6) then
+c               itau(j)=3
+c             else if (tau(j,ibox) .ge. 3.6 
+c    &          .and. tau(j,ibox) .lt. 9.4) then
+c                 itau(j)=4
+c             else if (tau(j,ibox) .ge. 9.4 
+c    &          .and. tau(j,ibox) .lt. 23.) then
+c                 itau(j)=5
+c             else if (tau(j,ibox) .ge. 23. 
+c    &          .and. tau(j,ibox) .lt. 60.) then
+c                 itau(j)=6
+c             else if (tau(j,ibox) .ge. 60.) then
+c                 itau(j)=7
+c             end if
+
+c             !determine cloud top pressure category
+c             if (    ptop(j,ibox) .gt. 0.  
+c    &          .and.ptop(j,ibox) .lt. 180.) then
+c                 ipres(j)=1
+c             else if(ptop(j,ibox) .ge. 180.
+c    &          .and.ptop(j,ibox) .lt. 310.) then
+c                 ipres(j)=2
+c             else if(ptop(j,ibox) .ge. 310.
+c    &          .and.ptop(j,ibox) .lt. 440.) then
+c                 ipres(j)=3
+c            else if(ptop(j,ibox) .ge. 440.
+c    &          .and.ptop(j,ibox) .lt. 560.) then
+c                 ipres(j)=4
+c             else if(ptop(j,ibox) .ge. 560.
+c    &          .and.ptop(j,ibox) .lt. 680.) then
+c                 ipres(j)=5
+c             else if(ptop(j,ibox) .ge. 680.
+c    &          .and.ptop(j,ibox) .lt. 800.) then
+c                 ipres(j)=6
+c             else if(ptop(j,ibox) .ge. 800.) then
+c                 ipres(j)=7
+c             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
+
+cIM calcul stats regime dynamique BEG
+!             iw(j) = int((w(j)-wmin)/pas_w) +1
+!             pctj(itau(j),ipres(j),iw(j))=.FALSE.
+!             !update frequencies W500
+!             if (pct_ocean(j)) then
+!             if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+!             if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+c             print*,' ISCCP iw=',iw(j),j
+!             fq_dynreg(itau(j),ipres(j),iw(j))=
+!    &          fq_dynreg(itau(j),ipres(j),iw(j))+
+!    &          boxarea
+c    &          fq_isccp(j,itau(j),ipres(j))
+!             pctj(itau(j),ipres(j),iw(j))=.TRUE.
+c             nfq_dynreg(itau(j),ipres(j),iw(j))=
+c    &          nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+!              end if
+!             end if
+!             end if
+cIM calcul stats regime dynamique END
+            end if !IM boxcloudy
+
+          end if !IM sunlit
+                       
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF sunlit boxcloudy t2 - t1',t2 - t1
+cIM
+        enddo !IM ibox/j
+
+
+cIM ajout stats s/ W500 BEG
+cIM ajout stats s/ W500 END
+
+c             if(j.EQ.6722) then
+c             print*,' ISCCP',w(j),iw(j),ipres(j),itau(j)
+c             endif
+
+!     if (pct_ocean(j)) then
+!     if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+!     if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+!     if(pctj(itau(j),ipres(j),iw(j))) THEN 
+!         nfq_dynreg(itau(j),ipres(j),iw(j))=
+!    &    nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+c         if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND.
+c    &    iw(j).EQ.10) then
+c         PRINT*,' isccp AVANT',
+c    &    nfq_dynreg(itau(j),ipres(j),iw(j)),
+c    &    fq_dynreg(itau(j),ipres(j),iw(j))
+c         endif
+!     endif
+!     endif
+!     endif
+!     endif
+39    continue !IM j/ibox
+      
+      !compute mean cloud properties
+      do j=1,npoints 
+        if (totalcldarea(j) .gt. 0.) then
+ 	  meanptop(j) = meanptop(j) / totalcldarea(j)
+          if (sunlit(j).eq.1) then
+            meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
+	    meantaucld(j) = tautab(min(255,max(1,nint(meanalbedocld(j))))) 
+          end if
+        end if
+      enddo ! j
+!
+cIM ajout stats s/ W500 BEG
+!     do nw = 1, iwmx
+!     do l = 1, 7
+!     do k = 1, 7
+!       if (nfq_dynreg(k,l,nw).GT.0.) then
+!       fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw)
+c        if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then
+c        print*,' isccp APRES',nfq_dynreg(k,l,nw),
+c    &   fq_dynreg(k,l,nw)
+c        endif
+!       else
+!        if(fq_dynreg(k,l,nw).NE.0.) then
+!        print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw)
+!        endif 
+c        fq_dynreg(k,l,nw) = -1.E+20
+c        nfq_dynreg(k,l,nw) = 1.E+20
+!       end if 
+!     enddo !k
+!     enddo !l
+!     enddo !nw
+cIM ajout stats s/ W500 END
+!     ---------------------------------------------------!
+
+!     ---------------------------------------------------!
+!     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
+!
+!cIM
+c      if (debugcol.ne.0) then
+!     
+c         do j=1,npoints,debugcol
+
+c            !produce character output
+c            do ilev=1,nlev
+c              do ibox=1,ncol
+c                   acc(ilev,ibox)=0
+c              enddo
+c            enddo
+
+c            do ilev=1,nlev
+c              do ibox=1,ncol
+c                   acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
+c                   if (levmatch(j,ibox) .eq. ilev) 
+c     &                 acc(ilev,ibox)=acc(ilev,ibox)+1
+c              enddo
+c            enddo
+
+             !print test
+
+c          write(ftn09,11) j
+c11        format('ftn09.',i4.4)
+c         open(9, FILE=ftn09, FORM='FORMATTED')
+
+c             write(9,'(a1)') ' '
+c                    write(9,'(10i5)')
+c     &                  (ilev,ilev=5,nlev,5)
+c             write(9,'(a1)') ' '
+             
+c             do ibox=1,ncol
+c               write(9,'(40(a1),1x,40(a1))')
+c     &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) 
+c     &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 
+c             end do
+c            close(9)
+c
+cIM
+c             if (ncolprint.ne.0) then
+c               write(6,'(a1)') ' '
+c                    write(6,'(a2,1X,5(a7,1X),a50)') 
+c     &                  'ilev',
+c     &                  'pfull','at',
+c     &                  'cc*100','dem_s','dtau_s',
+c     &                  '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
+c               write (6,'(a)') 'skt(j):'
+c               write (6,'(8f7.2)') skt(j)
+                                      
+c               write (6,'(8I7)') (ibox,ibox=1,ncolprint)
+	      
+c               write (6,'(a)') 'tau:'
+c               write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+    
+c               write (6,'(a)') 'tb:'
+c               write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+    
+c               write (6,'(a)') 'ptop:'
+c               write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
+c             endif 
+    
+c        enddo
+       
+c      end if 
+
+      return
+      end 
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/lnblnk1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/lnblnk1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/lnblnk1.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      INTEGER FUNCTION lnblnk1 (letter)
+
+C--------------------------------------------------------
+C Fonction qui determine la longeur d'un string sans les
+C blancs qui suivent. Le critere pour determiner la fin du
+C string est, trois blancs de suite
+C---------------------------------------------------------
+C     ARGUMENTS
+C     +++++++++
+C     letter: CHARACTER*xxx (xxx < imax)
+C             le string dont on determine la longuer
+C     lnblnk1: INTEGER
+C             le nombre de characteres
+C
+C     PARAMETER
+C     +++++++++
+C     imax : INTEGER
+C            le nombre maximale de character que peut contenir le string
+C            a traiter
+
+      IMPLICIT NONE
+      INTEGER i,imax
+      PARAMETER (imax = 256)
+c     CHARACTER*256 letter
+      CHARACTER*4 letter
+
+      i=0
+
+10    i=i+1
+c     IF (letter(i:i+1) . EQ . ' ') THEN
+      IF (letter(i:i) . EQ . ' ') THEN
+c      print*,'i=',i,'letter(i:i+1)=',letter(i:i+1)
+c      print*,'i=',i
+       GOTO 20
+      ELSE
+       GOTO 10
+      ENDIF
+
+20    lnblnk1=i-1
+c     PRINT*,'lnblnk1=',lnblnk1
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/minmaxqfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/minmaxqfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/minmaxqfi.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      CHARACTER*(*) comment
+      real qmin,qmax
+      real zq(klon,klev)
+
+      INTEGER jadrs(klon), jbad, k, i
+
+      DO k = 1, klev
+         jbad = 0
+         DO i = 1, klon
+         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+         IF (jbad.GT.0) THEN
+         PRINT*, comment
+         DO i = 1, jbad
+            PRINT*, "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
+         ENDDO
+         ENDIF
+      ENDDO
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_grid_phy_lmdz.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_grid_phy_lmdz.F90	(revision 984)
@@ -0,0 +1,447 @@
+!
+!$Header$
+!
+MODULE mod_grid_phy_lmdz
+  INTEGER :: nbp_lon  ! == iim
+  INTEGER :: nbp_lat  ! == jjmp1
+  INTEGER :: nbp_lev  ! == llm
+  INTEGER :: 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
+
+END MODULE mod_grid_phy_lmdz
+
+
+  
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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   
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_mpi_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_mpi_data.F90	(revision 984)
@@ -0,0 +1,199 @@
+!
+!$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_ok_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_PARA
+    is_ok_mpi=.TRUE.
+#else
+    is_ok_mpi=.FALSE.
+#endif
+    
+    klon_glo=iim*(jjp1-2)+2
+    
+    COMM_LMDZ_PHY=COMM_LMDZ
+
+    IF (is_ok_mpi) THEN    
+#ifdef CPP_PARA
+      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
+  
+  
+    PRINT *, 'ii_begin =', ii_begin
+    PRINT *, 'ii_end =', ii_end
+    PRINT *, 'jj_begin =',jj_begin
+    PRINT *, 'jj_end =', jj_end
+    PRINT *, 'jj_nb =', jj_nb
+    PRINT *, 'ij_begin =', ij_begin
+    PRINT *, 'ij_end =', ij_end
+    PRINT *, 'ij_nb =', ij_nb
+    PRINT *, 'klon_mpi_begin =', klon_mpi_begin
+    PRINT *, 'klon_mpi_end =', klon_mpi_end
+    PRINT *, 'klon_mpi =', klon_mpi
+    PRINT *, 'jj_para_nb =', jj_para_nb
+    PRINT *, 'jj_para_begin =', jj_para_begin
+    PRINT *, 'jj_para_end =', jj_para_end
+    PRINT *, 'ii_para_begin =', ii_para_begin
+    PRINT *, 'ii_para_end =', ii_para_end
+    PRINT *, 'ij_para_nb =', ij_para_nb
+    PRINT *, 'ij_para_begin =', ij_para_begin
+    PRINT *, 'ij_para_end =', ij_para_end
+    PRINT *, 'klon_mpi_para_nb =', klon_mpi_para_nb
+    PRINT *, 'klon_mpi_para_begin =', klon_mpi_para_begin
+    PRINT *, 'klon_mpi_para_end  =', klon_mpi_para_end 
+    PRINT *, 'mpi_rank =', mpi_rank
+    PRINT *, 'mpi_size =', mpi_size
+    PRINT *, 'mpi_root =', mpi_root
+    PRINT *, 'is_mpi_root =', is_mpi_root
+    PRINT *, 'is_north_pole =', is_north_pole
+    PRINT *, 'is_south_pole =', is_south_pole
+    PRINT *, 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_mpi_transfert.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_mpi_transfert.F90	(revision 984)
@@ -0,0 +1,2444 @@
+!
+!$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
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+
+    CALL bcast_mpi_cgen(Var1,len(Var1))
+  END SUBROUTINE bcast_mpi_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_mpi_i(var1)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var1
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var1,1)
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,1)
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,1)
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    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
+
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+     IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,1)
+     ELSE
+      CALL scatter_mpi_igen(dummy,Varout,1)
+    ENDIF
+    
+  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
+    
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2))
+    ENDIF
+    
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,1)
+    ENDIF
+    
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,1)      
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))      
+    ENDIF
+  
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+	INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+  
+ 
+  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
+
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+ 
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+ 
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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 :: dummy
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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 :: dummy
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+
+
+                            
+END MODULE mod_phys_lmdz_mpi_transfert
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+    
+#ifdef CPP_PARA
+    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,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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
+    
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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
+    
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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_PARA
+    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_ok_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_PARA 
+    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_PARA
+    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_ok_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_PARA 
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    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_ok_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+#ifdef CPP_PARA
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    INCLUDE 'mpif.h'
+#endif
+   
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+   
+    IF (.not.is_ok_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+#ifdef CPP_PARA
+    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_PARA
+    INCLUDE 'mpif.h'
+#endif
+    
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+ 
+    IF (.not.is_ok_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+#ifdef CPP_PARA
+    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   
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_omp_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_omp_data.F90	(revision 984)
@@ -0,0 +1,104 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_data
+
+  INTEGER,SAVE :: omp_size
+  INTEGER,SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_ok_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
+
+#ifdef _OPENMP    
+    INTEGER :: OMP_GET_NUM_THREADS
+    EXTERNAL OMP_GET_NUM_THREADS
+    INTEGER :: OMP_GET_THREAD_NUM
+    EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef _OPENMP
+!$OMP MASTER
+        is_ok_omp=.TRUE.
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+    is_ok_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
+     PRINT *,'ANORMAL : OMP_MASTER /= 0'
+     STOP
+   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
+
+!$OMP CRITICAL  
+  PRINT *,'--------> TASK ',omp_rank
+  PRINT *,'omp_size =',omp_size
+  PRINT *,'omp_rank =',omp_rank
+  PRINT *,'is_omp_root =',is_omp_root
+  PRINT *,'klon_omp_para_nb =',klon_omp_para_nb
+  PRINT *,'klon_omp_para_begin =',klon_omp_para_begin
+  PRINT *,'klon_omp_para_end =',klon_omp_para_end    
+  PRINT *,'klon_omp =',klon_omp
+  PRINT *,'klon_omp_begin =',klon_omp_begin
+  PRINT *,'klon_omp_end =',klon_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE Print_module_data
+END MODULE mod_phys_lmdz_omp_data
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_omp_transfert.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_omp_transfert.F90	(revision 984)
@@ -0,0 +1,1105 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  INTEGER,PARAMETER :: omp_buffer_size = 1024*1024*16
+  INTEGER,SAVE,DIMENSION(omp_buffer_size) :: omp_buffer
+  
+  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 
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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),omp_buffer)
+    
+  END SUBROUTINE bcast_omp_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_omp_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_igen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_i
+
+
+  SUBROUTINE bcast_omp_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i1
+
+
+  SUBROUTINE bcast_omp_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i2
+
+
+  SUBROUTINE bcast_omp_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i3
+
+
+  SUBROUTINE bcast_omp_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_rgen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_r
+
+
+  SUBROUTINE bcast_omp_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r1
+
+
+  SUBROUTINE bcast_omp_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r2
+
+
+  SUBROUTINE bcast_omp_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r3
+
+
+  SUBROUTINE bcast_omp_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r4
+
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_lgen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_l
+
+
+  SUBROUTINE bcast_omp_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l1
+
+
+  SUBROUTINE bcast_omp_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l2
+
+
+  SUBROUTINE bcast_omp_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l3
+
+
+  SUBROUTINE bcast_omp_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l4
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_igen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_i
+
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_i1
+  
+  
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_i2
+
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_i3
+
+
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_rgen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_r
+
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_r1
+  
+  
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_r2
+
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_r3
+  
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_lgen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_l
+
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_l1
+  
+  
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_l2
+
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_l3  
+  
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_igen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i2
+  
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i3
+
+
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_rgen(VarIn,dummy,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r3
+
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_lgen(VarIn,dummy,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l2
+  
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l3
+
+
+
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    CALL reduce_sum_omp_igen(VarIn,Varout,1,omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+   
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    CALL reduce_sum_omp_rgen(VarIn,Varout,1,omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+   
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  END SUBROUTINE reduce_sum_omp_r4
+
+
+
+END MODULE mod_phys_lmdz_omp_transfert
+
+
+
+
+
+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,DIMENSION(Nb),INTENT(INOUT) :: Var
+  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
+    
+  REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
+    
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_para.F90	(revision 984)
@@ -0,0 +1,106 @@
+!
+!$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
+  
+!$OMP THREADPRIVATE(klon_loc)
+  
+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
+    CALL Test_transfert
+!$OMP END PARALLEL    
+     IF (is_ok_mpi .OR. is_ok_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
+  
+    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)
+      PRINT *, "------> 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)
+      PRINT *, "------> 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)
+      PRINT *, "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+     
+   END SUBROUTINE Test_transfert
+  
+END MODULE mod_phys_lmdz_para
+    
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_transfert_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/mod_phys_lmdz_transfert_para.F90	(revision 984)
@@ -0,0 +1,1661 @@
+!
+!$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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(s1) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(s1,s2) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(s1,s2,s3) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3,s4)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3,s4
+      INTEGER,DIMENSION(s1,s2,s3,s4) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+   
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(s1) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(s1,s2) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(s1,s2,s3) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3,s4)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3,s4
+      REAL,DIMENSION(s1,s2,s3,s4) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+   
+  END SUBROUTINE reduce_sum_r4  
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/moy_undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/moy_undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/moy_undefSTD.F	(revision 984)
@@ -0,0 +1,83 @@
+!
+! $Header$
+!
+      SUBROUTINE moy_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $           tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Moyenne - a des frequences differentes - des valeurs bien definies
+c         (.NE.1.E+20) des variables interpolees a un niveau de
+c         pression.
+c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
+c    tous les pas de temps de la physique
+c
+c 2) les variables de type "NMC" (nout=3) sont calculees a partir
+c    des valeurs instantannees toutes les 6 heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c
+c variables Input
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime, ecrit_day, ecrit_mth, ecrit_hf2mth
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+c
+c variables Output
+      REAL tnondef(klon,klevSTD,nout)
+      REAL tsumSTD(klon,klevSTD,nout)
+c
+c calcul 1 fois par jour
+c
+      IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.0) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,1).NE.(ecrit_day/dtime)) THEN
+          tsumSTD(i,k,1)=tsumSTD(i,k,1)/
+     $    (ecrit_day/dtime-tnondef(i,k,1))
+         ELSE
+          tsumSTD(i,k,1)=1.E+20
+         ENDIF !tnondef
+        ENDDO !i
+       ENDDO !k
+      ENDIF !MOD(itap,ecrit_day).EQ.0
+c
+c calcul 1 fois par mois
+c
+      IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.0) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,2).NE.ecrit_mth/dtime) THEN
+          tsumSTD(i,k,2)=tsumSTD(i,k,2)/
+     $    (ecrit_mth/dtime-tnondef(i,k,2))
+         ELSE
+          tsumSTD(i,k,2)=1.E+20
+         ENDIF !tnondef
+c
+         IF(tnondef(i,k,3).NE.NINT(ecrit_hf2mth)) THEN
+          tsumSTD(i,k,3)=tsumSTD(i,k,3)/
+     $    (ecrit_hf2mth-tnondef(i,k,3))
+         ELSE
+          tsumSTD(i,k,3)=1.E+20
+         ENDIF !tnondef
+c
+        ENDDO !i
+       ENDDO !k
+      ENDIF !MOD
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/moyglo_aire.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/moyglo_aire.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/moyglo_aire.F	(revision 984)
@@ -0,0 +1,161 @@
+!
+! $Header$
+!
+      SUBROUTINE moyglo_pondaire(nhori, champ, aire, 
+     .            ok_msk, msk, moyglo)
+c
+       USE dimphy
+       IMPLICIT none
+c
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
+c
+c moyenne = Somme_(champ* aire)/Somme_aire
+c
+c ==================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+       INTEGER i, nhori
+       REAL champ(klon), aire(klon), msk(klon)
+       LOGICAL ok_msk 
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaire nhori',nhori
+c
+       airetot=0.
+       moyglo=0.
+c
+       IF(ok_msk) THEN
+        DO i=1, nhori
+c        IF(msk(i).EQ.1.) THEN 
+         IF(msk(i).GT.0.) THEN 
+c
+c aire totale
+          airetot=airetot+aire(i)*msk(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i)*msk(i) 
+         ENDIF
+        ENDDO
+c
+       ELSE !ok_msk
+        DO i=1, nhori
+c
+c aire totale
+          airetot=airetot+aire(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i) 
+        ENDDO 
+c
+       ENDIF
+c 
+c moyenne ponderee par l'aire
+       moyglo=moyglo/airetot
+c
+       RETURN 
+       END
+c
+       SUBROUTINE moyglo_pondaima(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
+c totale avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_aire
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c aire totale
+       airetot=0.
+       DO i=1, nhori
+        airetot=airetot+aire(i)
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/airetot
+c
+      RETURN
+      END
+c
+       SUBROUTINE moyglo_pondmass(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par la
+c masse totale d'air, avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL massetot
+c
+c      PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c masse totale
+       massetot=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        massetot=massetot+
+     .  (pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/massetot
+c
+      RETURN
+      END
+c
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/newmicro.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/newmicro.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/newmicro.F	(revision 984)
@@ -0,0 +1,364 @@
+!
+! $Header$
+!
+      SUBROUTINE newmicro (paprs, pplay,ok_newmicro,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     s                  xflwp, xfiwp, xflwc, xfiwc,
+     e                  ok_aie, 
+     e                  sulfate, sulfate_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c 
+c ok_aie--input-L-apply aerosol indirect effect or not
+c sulfate-input-R-sulfate aerosol mass concentration [um/m^3]
+c sulfate_pi-input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell           
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "nuage.h"
+cIM cf. CR: include pour NOVLP et ZEPSEC
+#include "radepsi.h"
+#include "radopt.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+cIM: 091003   REAL zflwp, zradef, zfice, zmsac
+      REAL zflwp(klon), zradef, zfice, zmsac
+cIM: 091003 rajout
+      REAL xflwp(klon), xfiwp(klon)
+      REAL xflwc(klon,klev), xfiwc(klon,klev)
+c
+      REAL radius, rad_chaud
+cc      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+ccc      PARAMETER (nexpo=1)
+
+c -- sb:
+      logical ok_newmicro
+c     parameter (ok_newmicro=.FALSE.)
+cIM: 091003   real rel, tc, rei, zfiwp
+      real rel, tc, rei, zfiwp(klon)
+      real k_liq, k_ice0, k_ice, DF
+      parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g
+      parameter (DF=1.66) ! diffusivity factor
+c sb --
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      LOGICAL ok_a1lwpdep       ! a1 LWP dependent?
+      
+      REAL sulfate(klon, klev)  ! sulfate aerosol mass concentration [ug m-3]
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL sulfate_pi(klon, klev)  ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value)
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)       ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end    
+cIM cf. CR:parametres supplementaires
+      REAL zclear(klon)
+      REAL zcloud(klon) 
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+cIM inversion des DO
+      DO i = 1, klon
+       xflwp(i)=0.
+       xfiwp(i)=0.
+cccccccccccc!CDIR NOVECTOR
+      DO k = 1, klev
+c
+       xflwc(i,k)=0.
+       xfiwc(i,k)=0.
+c
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp(i) = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp(i) / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp(i))
+
+         if (ok_newmicro) then
+
+c -- liquid/ice cloud water paths:
+
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+
+         zflwp(i) = 1000.*(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         zfiwp(i) = 1000.*zfice*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+         xflwp(i) = xflwp(i)+ (1.-zfice)*pqlwp(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         xfiwp(i) = xfiwp(i)+ zfice*pqlwp(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+cIM Total Liquid/Ice water content
+         xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)
+         xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)
+cIM In-Cloud Liquid/Ice water content
+c        xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+c        xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)/pclc(i,k)
+
+c -- effective cloud droplet radius (microns):
+
+c for liquid water clouds: 
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            !
+            !
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+c           rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            rad_chaud = MAX(rad_chaud*1.e6, 5.) 
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc_pi(i,k)) )**(1./3.)
+            radius = MAX(radius*1.e6, 5.) 
+            
+            tc = t(i,k)-273.15
+            rei = 0.71*tc + 61.29 
+            if (tc.le.-81.4) rei = 3.5 
+            if (zflwp(i).eq.0.) radius = 1. 
+            if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. 
+            cldtaupi(i,k) = 3.0/2.0 * zflwp(i) / radius
+     .             + zfiwp(i) * (3.448e-03  + 2.431/rei)
+         ENDIF                  ! ok_aie
+         ! For output diagnostics
+         !
+         ! Cloud droplet effective radius [um]
+         !
+         ! we multiply here with f * xl (fraction of liquid water
+         ! clouds in the grid cell) to avoid problems in the
+         ! averaging of the output.
+         ! In the output of IOIPSL, derive the real cloud droplet 
+         ! effective radius as re/fl
+         !
+         fl(i,k) = pclc(i,k)*(1.-zfice)            
+         re(i,k) = rad_chaud*fl(i,k)
+            
+c-jq end         
+         
+         rel = rad_chaud
+c for ice clouds: as a function of the ambiant temperature
+c [formula used by Iacobellis and Somerville (2000), with an 
+c asymptotical value of 3.5 microns at T<-81.4 C added to be 
+c consistent with observations of Heymsfield et al. 1986]:
+         tc = t(i,k)-273.15
+         rei = 0.71*tc + 61.29 
+         if (tc.le.-81.4) rei = 3.5 
+
+c -- cloud optical thickness :
+
+c [for liquid clouds, traditional formula, 
+c  for ice clouds, Ebert & Curry (1992)] 
+
+         if (zflwp(i).eq.0.) rel = 1. 
+         if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. 
+         pcltau(i,k) = 3.0/2.0 * ( zflwp(i)/rel )
+     .             + zfiwp(i) * (3.448e-03  + 2.431/rei)
+
+c -- cloud infrared emissivity:
+
+c [the broadband infrared absorption coefficient is parameterized
+c  as a function of the effective cld droplet radius]
+
+c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+         k_ice = k_ice0 + 1.0/rei
+
+         pclemi(i,k) = 1.0
+     .      - EXP( - coef_chau*zflwp(i) - DF*k_ice*zfiwp(i) )
+
+         endif ! ok_newmicro
+
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (lo) cldtaupi(i,k) = 0.0
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+cIM cf. CR:test: calcul prenant ou non en compte le recouvrement
+cinitialisations
+      DO i=1,klon
+         zclear(i)=1.
+         zcloud(i)=0.
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+cIM cf CR DO k=1,klev
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+cIM cf. CR
+            IF (NOVLP.EQ.1) THEN
+               zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               pct(i)=1.-zclear(i) 
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+                  pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then
+                  pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then 
+                  pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               endif
+               zcloud(i)=pclc(i,k)
+            ELSE IF (NOVLP.EQ.2) THEN
+               zcloud(i)=MAX(pclc(i,k),zcloud(i))
+               pct(i)=zcloud(i)
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+                  pch(i) = MIN(pclc(i,k),pch(i))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then
+                  pcm(i) = MIN(pclc(i,k),pcm(i))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then
+                  pcl(i) = MIN(pclc(i,k),pcl(i))
+               endif
+            ELSE IF (NOVLP.EQ.3) THEN
+               zclear(i)=zclear(i)*(1.-pclc(i,k))
+               pct(i)=1-zclear(i)
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+               pch(i) = pch(i)*(1.0-pclc(i,k))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then 
+               pcm(i) = pcm(i)*(1.0-pclc(i,k))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then
+               pcl(i) = pcl(i)*(1.0-pclc(i,k))
+               endif
+            ENDIF
+         ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+cIM cf. CR          pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nflxtr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nflxtr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nflxtr.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pplay,paprs,x,dx) 
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant 
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--flux convectifs mais en variables locales
+      REAL zmfu(klon,klev+1) 
+      REAL zmfd(klon,klev+1) 
+      REAL zen_u(klon,klev) 
+      REAL zde_u(klon,klev)
+      REAL zen_d(klon,klev) 
+      REAL zde_d(klon,klev)
+      real zmfe
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+
+c =========================================
+c
+c
+c   Extension des flux UP et DN sur klev+1 niveaux
+c =========================================
+      do k=1,klev
+         do i=1,klon
+            zmfu(i,k)=pmfu(i,k)
+            zmfd(i,k)=pmfd(i,k)
+         enddo
+      enddo
+      do i=1,klon
+         zmfu(i,klev+1)=0.
+         zmfd(i,klev+1)=0.
+      enddo
+
+c--modif pour diagnostiquer les detrainements
+c =========================================
+c   on privilegie l'ajustement de l'entrainement dans l'ascendance.
+
+      do k=1, klev
+         do i=1, klon
+            zen_d(i,k)=pen_d(i,k)
+            zde_u(i,k)=pde_u(i,k)
+            zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
+            zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
+         enddo 
+      enddo 
+c
+c--calcul des flux dans le panache montant
+c =========================================
+c
+c Dans la premiere couche, on prend q comme valeur de qu
+c
+      do i=1, klon
+         zmfux(i,1)=0.0 
+      enddo
+c
+c Autres couches
+      do k=1,klev
+         do i=1, klon
+            if ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
+               xu(i,k)=x(i,k)
+            else
+               xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))
+     s               /(zmfu(i,k+1)+zde_u(i,k))
+            endif
+            zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
+         enddo
+      enddo
+c
+c--calcul des flux dans le panache descendant
+c =========================================
+c   
+      do i=1, klon
+         zmfdx(i,klev+1)=0.0 
+      enddo
+c
+      do k=klev,1,-1
+         do i=1, klon
+            if ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
+               xd(i,k)=x(i,k)
+            else
+               xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k)) /
+     .               (zmfd(i,k)-zde_d(i,k))
+            endif
+            zmfdx(i,k)=zmfd(i,k)*xd(i,k)
+         enddo
+      enddo
+c
+c--introduction du flux de retour dans l'environnement
+c =========================================
+c
+      do k=2, klev
+         do i=1, klon
+            zmfe=-zmfu(i,k)-zmfd(i,k)
+            if (zmfe.le.0.) then
+               zmfex(i,k)= zmfe*x(i,k)
+            else
+               zmfex(i,k)= zmfe*x(i,k-1)
+            endif
+         enddo
+      enddo
+
+      do i=1, klon
+         zmfex(i,1)=0.
+         zmfex(i,klev+1)=0.
+      enddo
+c
+c--calcul final des tendances
+c
+      do k=1, klev
+         do i=1, klon
+            dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*
+     .                      ( zmfux(i,k) - zmfux(i,k+1) +
+     .                        zmfdx(i,k) - zmfdx(i,k+1) +
+     .                        zmfex(i,k) - zmfex(i,k+1) )
+         enddo
+      enddo
+c
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nonlocal.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nonlocal.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nonlocal.F	(revision 984)
@@ -0,0 +1,415 @@
+!
+! $Header$
+!
+C======================================================================
+      SUBROUTINE nonlocal(knon, paprs, pplay,
+     .                    tsol,beta,u,v,t,q,
+     .                    cd_h, cd_m, pcfh, pcfm, cgh, cgq)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+#include "YOMCST.h"
+#include "iniprint.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL tsol(klon) ! temperature du sol (K)
+      REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+      REAL vk
+      PARAMETER (vk=0.40)
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)
+      REAL fakn
+      PARAMETER (fakn=7.2)
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)
+      REAL sffrac
+      PARAMETER (sffrac=0.1)
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL z(klon,klev)
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL ustar(klon)
+      REAL rino(klon,klev)  ! bulk Richardon no. from level to ref lev
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      REAL pblh(klon)
+      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)
+      REAL ztvd, ztvu, zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5, zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation
+c
+      isommet=klev
+
+      DO i = 1, klon
+         pcfh(i,1) = cd_h(i)
+         pcfm(i,1) = cd_m(i)
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         pcfh(i,k) = zkmin
+         pcfm(i,k) = zkmin
+         cgs(i,k) = 0.0
+         cgh(i,k) = 0.0
+         cgq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+      ENDDO
+      ENDDO
+c
+      DO i = 1, knon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+           zxqs=MIN(0.5,zxqs)
+           zcor=1./(1.-retv*zxqs)
+           zxqs=zxqs*zcor
+         ELSE
+           IF (tsol(i).LT.t_coup) THEN
+              zxqs = qsats(tsol(i)) / paprs(i,1)
+           ELSE
+              zxqs = qsatl(tsol(i)) / paprs(i,1)
+           ENDIF
+         ENDIF
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .        *(1.+RETV*q(i,1))*zx_alf1
+     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+     .        *(1.+RETV*q(i,2))*zx_alf2
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+      ENDDO
+c
+      DO i = 1, knon
+         rino(i,1) = 0.0
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+      ENDDO
+
+C
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C
+      fac = 100.0
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+        wm(i)= ustar(i)*phiminv(i)
+        therm(i) = heatv(i)*fak/wm(i)
+        rino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+C Improve pblh estimate for unstable conditions using the
+C convective temperature excess:
+C
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Points for which pblh exceeds number of pbl layers allowed;
+C set to maximum
+C
+      DO i = 1, knon
+        IF (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+      ENDDO
+C
+C pblh is now available; do preparation for diffusivity calculation:
+C
+      DO i = 1, knon
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C
+        IF (unstbl(i)) THEN
+          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+C
+C For all unstable layers, set diffusivities
+C
+        DO i = 1, knon
+        IF (unslev(i)) THEN
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pblk(i)/pr(i)
+        ENDIF
+        ENDDO
+ 1000 continue           ! end of level loop
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nuage.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nuage.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nuage.F	(revision 984)
@@ -0,0 +1,409 @@
+!
+! $Header$
+!
+      SUBROUTINE nuage (paprs, pplay,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     e                  ok_aie,
+     e                  sulfate, sulfate_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c ok_aie--input-L-apply aerosol indirect effect or not
+c sulfate-input-R-sulfate aerosol mass concentration [um/m^3]
+c sulfate_pi-input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell      
+c 
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+c
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+      
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      
+      REAL sulfate(klon, klev)  ! sulfate aerosol mass concentration [ug m-3]
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL sulfate_pi(klon, klev)  ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value)
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)  ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end      
+      
+ccc      PARAMETER (nexpo=1)
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+            
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+            rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            
+            ! For output diagnostics
+            !
+            ! Cloud droplet effective radius [um]
+            !
+            ! we multiply here with f * xl (fraction of liquid water
+            ! clouds in the grid cell) to avoid problems in the
+            ! averaging of the output.
+            ! In the output of IOIPSL, derive the real cloud droplet 
+            ! effective radius as re/fl
+            !
+            fl(i,k) = pclc(i,k)*(1.-zfice)            
+            re(i,k) = rad_chaud*fl(i,k)
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k)))  
+     .                / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.), 
+     .               3.) * (1.-zfice) + rad_froid * zfice           
+            cldtaupi(i,k) = 3.0/2.0 * zflwp / radius
+     .           
+         ENDIF                  ! ok_aie
+         
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))
+     .      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .       pplay(i,k).LE.cetamb*paprs(i,1)) 
+     .      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))
+     .      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,
+     .                   diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+c Laurent Li (LMD/CNRS), le 12 octobre 1998
+c                        (adaptation du code ECMWF)
+c
+c Dans certains cas, le schema pronostique des nuages n'est
+c pas suffisament performant. On a donc besoin de diagnostiquer
+c ces nuages. Je dois avouer que c'est une frustration.
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+c
+c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon ! pour traiter les enclumes
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.
+     .    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))
+     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
+     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+c
+c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))
+     .          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.
+     .       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)
+     .   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nuage.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nuage.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/nuage.h	(revision 984)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      REAL rad_froid, rad_chau1, rad_chau2
+
+      common /nuagecom/ rad_froid,rad_chau1, rad_chau2
+!$OMP THREADPRIVATE(/nuagecom/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/o3cm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/o3cm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/o3cm.F	(revision 984)
@@ -0,0 +1,61 @@
+!
+! $Header$
+!
+      SUBROUTINE o3cm (amb, bmb, sortie, ntab)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ce programme calcule le contenu en ozone "sortie"
+c        (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb)
+c        "ntab" est le nombre d'intervalles pour l'integration, sa
+c        valeur depend bien sur de l'epaisseur de la couche et de
+c        la precision qu'on souhaite a obtenir
+c======================================================================
+      REAL amb, bmb, sortie
+      INTEGER ntab
+c======================================================================
+      INTEGER n
+      REAL xtab(500), xa, xb, ya, yb, xincr
+c======================================================================
+      external mbtozm
+c======================================================================
+c la fonction en ligne w(x) donne le profil de l'ozone en fonction
+c de l'altitude (unite: cm.atm / km)
+c (Green 1964, Appl. Opt. 3: 203-208)
+      REAL wp, xp, h, x, w, con
+      PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0)
+      w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2
+c======================================================================
+      IF (ntab .GT. 499) STOP 'BIG ntab'
+      xincr = (bmb-amb) / FLOAT(ntab)
+      xtab(1) = amb
+      DO n = 2, ntab
+         xtab(n) = xtab(n-1) + xincr
+      ENDDO
+      xtab(ntab+1) = bmb
+      sortie = 0.0
+      DO n = 1, ntab
+         CALL mbtozm(xtab(n), xa)
+         CALL mbtozm(xtab(n+1), xb)
+         xa = xa / 1000.
+         xb = xb / 1000.
+         ya = w(xa)
+         yb = w(xb)
+         sortie = sortie + (ya+yb)/2.0 * ABS(xb-xa)
+      ENDDO
+      RETURN
+      END
+      SUBROUTINE mbtozm(rmb,zm)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Objet: transformer une hauteur de mb (rmb) en metre (zm)
+c======================================================================
+      REAL rmb, zm
+c======================================================================
+      REAL gama, tzero, pzero, g, r
+      PARAMETER (gama=6.5e-3, tzero=288., pzero=1013.25)
+      PARAMETER (g=9.81, r=287.0)
+      zm = tzero/gama * ( 1.-(rmb/pzero)**(r*gama/g) )
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/oasis.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/oasis.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/oasis.F90	(revision 984)
@@ -0,0 +1,396 @@
+!
+! $Header$
+!
+MODULE oasis
+!
+! This module contains subroutines for initialization, sending and receiving 
+! towards the coupler OASIS3. It also contains some parameters for the coupling.
+!
+! This module should always be compiled. With the coupler OASIS3 available the cpp key
+! CPP_COUPLE should be set and the entier of this file will then be compiled. 
+! In a forced mode CPP_COUPLE should not be defined and the compilation ends before 
+! the CONTAINS, without compiling the subroutines.
+!
+  USE dimphy 
+  USE mod_phys_lmdz_para
+  USE write_field_phy
+
+#ifdef CPP_COUPLE
+  USE mod_prism_proto
+  USE mod_prism_def_partition_proto
+  USE mod_prism_get_proto
+  USE mod_prism_put_proto
+#endif
+  
+  IMPLICIT NONE
+    
+! Maximum number of fields exchanged between ocean and atmosphere
+  INTEGER, PARAMETER  :: jpmaxfld=40
+! Number of fields exchanged from atmosphere to ocean via flx.F
+  INTEGER, PARAMETER  :: jpflda2o1=13
+! Number of fields exchanged from atmosphere to ocean via tau.F
+  INTEGER, PARAMETER  :: jpflda2o2=6
+! Number of fields exchanged from ocean to atmosphere
+  INTEGER, PARAMETER  :: jpfldo2a=4
+
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_read
+  !$OMP THREADPRIVATE(cl_read)
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_writ
+  !$OMP THREADPRIVATE(cl_writ)
+
+  INTEGER, DIMENSION(jpfldo2a), SAVE, PRIVATE            :: in_var_id
+  !$OMP THREADPRIVATE(in_var_id)
+  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
+  !$OMP THREADPRIVATE(out_var_id)
+
+
+#ifdef CPP_COUPLE
+
+CONTAINS
+
+  SUBROUTINE inicma
+!************************************************************************************
+!**** *INICMA*  - Initialize coupled mode communication for atmosphere
+!                 and exchange some initial information with Oasis
+!
+!     Rewrite to take the PRISM/psmile library into account
+!     LF 09/2003
+!
+    INCLUDE "dimensions.h"
+
+! Local variables
+!************************************************************************************
+    INTEGER                            :: comp_id
+    INTEGER                            :: ierror, il_commlocal
+    INTEGER                            :: il_part_id
+    INTEGER, DIMENSION(3)              :: ig_paral
+    INTEGER, DIMENSION(2)              :: il_var_nodims
+    INTEGER, DIMENSION(4)              :: il_var_actual_shape
+    INTEGER                            :: il_var_type
+    INTEGER                            :: nuout = 6
+    INTEGER                            :: jf
+    CHARACTER (len = 6)                :: clmodnam
+    CHARACTER (len = 20)               :: modname = 'inicma'
+    CHARACTER (len = 80)               :: abort_message 
+
+!*    1. Initializations
+!        ---------------
+!************************************************************************************
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' ROUTINE INICMA'
+    WRITE(nuout,*) ' **************'
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+
+!
+! Define the model name
+!
+    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+!
+!************************************************************************************
+! Here we go: psmile initialisation
+!************************************************************************************
+    IF (is_sequential) THEN
+       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
+       
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_init_comp '
+          CALL abort_gcm(modname,abort_message,1)
+       ELSE
+          WRITE(nuout,*) 'inicma : init psmile ok '
+       ENDIF
+    ENDIF
+
+    CALL prism_get_localcomm_proto (il_commlocal, ierror)
+!************************************************************************************
+! Domain decomposition
+!************************************************************************************
+    ig_paral(1) = 1                            ! apple partition for //
+    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
+    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
+
+    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
+    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
+    
+    ierror=PRISM_Ok
+    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
+
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme dans prism_def_partition '
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
+    ENDIF
+
+!************************************************************************************
+! Field Declarations
+!************************************************************************************
+!     Define symbolic name for fields exchanged from atmos to coupler,
+!         must be the same as (1) of the field  definition in namcouple:
+    cl_writ(1)='COTAUXXU'
+    cl_writ(2)='COTAUYYU'
+    cl_writ(3)='COTAUZZU'
+    cl_writ(4)='COTAUXXV'
+    cl_writ(5)='COTAUYYV'
+    cl_writ(6)='COTAUZZV'
+    cl_writ(7)='COWINDSP'
+    cl_writ(8)='COSHFICE'
+    cl_writ(9)='COSHFOCE'
+    cl_writ(10)='CONSFICE'
+    cl_writ(11)='CONSFOCE'
+    cl_writ(12)='CODFLXDT'
+    cl_writ(13)='COTFSICE'
+    cl_writ(14)='COTFSOCE'
+    cl_writ(15)='COTOLPSU'
+    cl_writ(16)='COTOSPSU'
+    cl_writ(17)='CORUNCOA'
+    cl_writ(18)='CORIVFLU'
+    cl_writ(19)='COCALVIN'
+!
+!     Define symbolic name for fields exchanged from coupler to atmosphere,
+!         must be the same as (2) of the field  definition in namcouple:
+!
+    cl_read(1)='SISUTESW'
+    cl_read(2)='SIICECOV'
+    cl_read(3)='SIICEALW'
+    cl_read(4)='SIICTEMW'
+    
+    il_var_nodims(1) = 2
+    il_var_nodims(2) = 1
+
+    il_var_actual_shape(1) = 1
+    il_var_actual_shape(2) = iim
+    il_var_actual_shape(3) = 1
+    il_var_actual_shape(4) = jjm+1
+   
+    il_var_type = PRISM_Real
+
+!************************************************************************************
+! Oceanic Fields
+!************************************************************************************
+    DO jf=1, jpfldo2a
+       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
+            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! Atmospheric Fields
+!************************************************************************************
+    DO jf=1, jpflda2o1+jpflda2o2
+       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
+            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! End definition
+!************************************************************************************
+    CALL prism_enddef_proto(ierror)
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme init dans prism_ endef_proto'
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : endef psmile ok '
+    ENDIF
+    
+  END SUBROUTINE inicma
+
+!
+!************************************************************************************
+!
+
+  SUBROUTINE fromcpl(ktime, tab_get)
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
+! and Sea-Ice provided by the coupler. Adaptation to psmile library
+!======================================================================
+!
+    INCLUDE "dimensions.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                               ::  ktime
+
+! Output arguments
+!************************************************************************************
+    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
+
+! Local variables
+!************************************************************************************
+    INTEGER                       :: nuout  = 6             ! listing output unit
+    INTEGER                       :: ierror, i
+    INTEGER                       :: istart,iend
+    CHARACTER (len = 20)          :: modname = 'fromcpl'
+    CHARACTER (len = 80)          :: abort_message 
+    REAL, DIMENSION(iim*jj_nb)    :: field
+
+!************************************************************************************
+    WRITE (nuout,*) ' '
+    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
+    WRITE (nuout,*) ' '
+    CALL flush (nuout)
+    
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    DO i = 1, jpfldo2a
+       field(:) = -99999.
+       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
+       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
+            ierror.NE.PRISM_FromRest &
+            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
+            .AND. ierror.NE.PRISM_FromRestOut) THEN
+          WRITE (nuout,*)  cl_read(i), ktime   
+          abort_message=' Probleme dans prism_get_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+    
+    
+  END SUBROUTINE fromcpl
+
+!
+!************************************************************************************
+! 
+
+  SUBROUTINE intocpl(ktime, last, tab_put) 
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
+! atmospheric coupling fields to the coupler with the psmile library.
+! IF last time step, writes output fields to binary files.
+! ======================================================================
+!
+! 
+    INCLUDE "dimensions.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                                          :: ktime
+    LOGICAL, INTENT(IN)                                          :: last
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
+
+! Local variables
+!************************************************************************************
+    LOGICAL                     :: checkout=.FALSE.
+    INTEGER                     :: istart,iend
+    INTEGER                     :: wstart,wend
+    INTEGER, PARAMETER          :: nuout = 6 
+    INTEGER                     :: ierror, i
+    REAL, DIMENSION(iim*jj_nb)  :: field
+    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
+    CHARACTER (len = 80)        :: abort_message 
+
+!************************************************************************************
+
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
+    WRITE(nuout,*) 'last  ', last
+    WRITE(nuout,*)
+
+
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    IF (checkout) THEN   
+       wstart=istart
+       wend=iend
+       IF (is_north_pole) wstart=istart+iim-1
+       IF (is_south_pole) wend=iend-iim+1
+       
+       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
+       CALL writeField_phy("fsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
+       CALL writeField_phy("fsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
+       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
+       CALL writeField_phy("evice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
+       CALL writeField_phy("evwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
+       CALL writeField_phy("lpre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
+       CALL writeField_phy("spre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
+       CALL writeField_phy("dirunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
+       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
+       CALL writeField_phy("calving",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
+       CALL writeField_phy("windsp",field(wstart:wend),1)
+    ENDIF
+   
+!************************************************************************************
+! PRISM_PUT
+!************************************************************************************
+
+    DO i = 1, jpflda2o1+jpflda2o2
+       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
+       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
+            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
+            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
+          WRITE (nuout,*)  cl_writ(i), ktime   
+          abort_message=' Probleme dans prism_put_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+    END DO
+   
+!************************************************************************************
+! Finalize PSMILE for the case is_sequential, if parallel finalization is done 
+! from Finalize_parallel in dyn3dpar/parallel.F90
+!************************************************************************************
+
+    IF (last) THEN
+       IF (is_sequential) THEN 
+          CALL prism_terminate_proto(ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             abort_message=' Probleme dans prism_terminate_proto '
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    ENDIF
+    
+    
+  END SUBROUTINE intocpl
+
+#endif
+  
+END MODULE oasis
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_cpl_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_cpl_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_cpl_mod.F90	(revision 984)
@@ -0,0 +1,370 @@
+!
+! $Header$
+!
+MODULE ocean_cpl_mod
+!
+! This module is used both for the sub-surface ocean and sea-ice for the case of a 
+! coupled model configuration, ocean=couple. 
+!
+
+  USE dimphy,           ONLY : klon
+  USE cpl_mod
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE climb_wind_mod,   ONLY : calcul_wind_flux
+
+  IMPLICIT NONE
+  PRIVATE
+
+  PUBLIC :: ocean_cpl_init, ocean_cpl_get_vars, ocean_cpl_noice, ocean_cpl_ice
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_o
+  !$OMP THREADPRIVATE(tmp_flux_o)
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_g)
+
+!****************************************************************************************
+!
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
+!
+! Allocate fields for this module and initailize the module mod_cpl
+!
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
+
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! Initialize module cpl_init
+    CALL cpl_init(dtime, rlon, rlat)
+    
+  END SUBROUTINE ocean_cpl_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_noice( &
+       sollw, albedo, &
+       windsp, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       swdown, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice. The subroutine first receives fields from coupler, then some calculations at 
+! surface is done and finally it sends some fields to the coupler.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+!    
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    INTEGER, DIMENSION(1) :: iloc
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: zx_sl
+    REAL, DIMENSION(klon) :: fder_new
+    REAL, DIMENSION(klon) :: tsurf_cpl
+    REAL, DIMENSION(klon) :: taux, tauy
+    LOGICAL               :: check=.FALSE.
+
+! End definitions
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
+
+!****************************************************************************************
+! Receive sea-surface temperature(tsurf_cpl) and new fraction of ocean surface(pctsrf_oce) 
+! from coupler
+!
+!****************************************************************************************
+    CALL cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf_in, &
+         tsurf_cpl, pctsrf_oce)
+
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    ! Calcultate the flux of u and v at surface
+    CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!****************************************************************************************
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+       !IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+       !       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_ocean_fields(itime, knon, knindex, &
+         swdown, sollw, fluxlat, fluxsens, &
+         precip_rain, precip_snow, evap, tsurf_new, fder_new, albedo, taux, tauy, windsp)
+    
+
+  END SUBROUTINE ocean_cpl_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_ice( &
+       rlon, rlat, sollw, albedo, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       lafin, &
+       swdown, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, &
+       alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. The subroutine first receives 
+! fields from coupler, then some calculations at surface is done and finally sends 
+! some fields to the coupler.
+!    
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                 :: i
+    INTEGER, DIMENSION(1)   :: iloc
+    LOGICAL                 :: check=.FALSE.
+    REAL, PARAMETER         :: t_grnd=271.35
+    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
+    REAL, DIMENSION(klon)   :: taux, tauy
+
+! End definitions
+!****************************************************************************************
+    
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! Receive ocean temperature(tsurf_cpl), albedo(alb_new) and new fraction of 
+! seaice(pctsrf_sic) from coupler
+!
+!****************************************************************************************
+
+    CALL cpl_receive_seaice_fields(knon, knindex, &
+         tsurf_cpl, alb_new, pctsrf_sic)
+    
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    dif_grnd = 0.
+    beta = 1.0
+    
+
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    ! Calcultate the flux of u and v at surface
+    CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!  IM: faire dependre le coefficient de conduction de la glace de mer
+!      de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!      actuel correspond a 3m de glace de mer, cf. L.Li
+!
+!****************************************************************************************
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_sic(knindex(i)) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * &
+            dif_grnd(i) * RCPD/cal(i) 
+    ENDDO
+    
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder ****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf_in, lafin, rlon, rlat, &
+       swdown, sollw, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf_new, fder_new, albedo, taux, tauy)
+ 
+
+    alblw(1:knon) = alb_new(1:knon)    
+
+  END SUBROUTINE ocean_cpl_ice
+!  
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_get_vars(flux_o, flux_g)
+
+! This subroutine returns variables private in this module to an external 
+! routine (physiq).
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Set the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_cpl_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_cpl_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_forced_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_forced_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_forced_mod.F90	(revision 984)
@@ -0,0 +1,365 @@
+!
+! $Header$
+!
+MODULE ocean_forced_mod
+!
+! This module is used for both the sub-surfaces ocean and sea-ice for the case of a 
+! forced ocean,  "ocean=force".
+!
+  USE surface_data,     ONLY : calice, calsno, tau_gl
+  USE fonte_neige_mod,  ONLY : fonte_neige
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE dimphy
+
+  IMPLICIT NONE
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+
+CONTAINS
+!
+!****************************************************************************************
+! 
+  SUBROUTINE ocean_forced_init
+! Allocate fields needed for this module
+!    
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_forced_init'
+!****************************************************************************************
+
+    ALLOCATE(tmp_flux_o(1:klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(1:klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF    
+
+
+  END SUBROUTINE ocean_forced_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_noice(itime, dtime, jour, knon, knindex, &
+       debut, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, &
+       temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, &
+       agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice.
+! The routine reads data from climatologie file and does some calculations at the 
+! surface. 
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: debut
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno !? put to 0 in ocean
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER                     :: i
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_lim, zx_sl
+    LOGICAL                     :: check=.FALSE.
+    REAL, DIMENSION(klon,nbsrf) :: pctsrf_lim
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_forced_noice'
+
+!****************************************************************************************
+! 1)    
+! Read from climatologie file SST and fraction of sub-surfaces
+!
+!****************************************************************************************
+! Get from file tsurf_lim and pctsrf_lim
+    CALL interfoce_lim(itime, dtime, jour, & 
+         knon, knindex, &
+         debut, &
+         tsurf_lim, pctsrf_lim)
+    
+!****************************************************************************************
+! 2)
+! Flux calculation
+!
+!****************************************************************************************
+! Set some variables for calcul_fluxs
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+  
+! 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, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!****************************************************************************************
+! 3)
+! Calculate tmp_flux_o
+!
+!****************************************************************************************
+!IM: flux ocean-atmosphere utile pour le "slab" ocean
+! The flux are written to hist file
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+
+!IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+!       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_lim(knindex(i),is_oce) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+!****************************************************************************************
+! 4)
+! Return the new values for the ocean fraction
+!
+!****************************************************************************************
+
+    pctsrf_oce(:) = pctsrf_lim(:,is_oce)
+
+  END SUBROUTINE ocean_forced_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_ice(itime, dtime, jour, knon, knindex, &
+       debut, &
+       tsurf_in, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. 
+! The routine reads data from climatologie file and does flux calculations at the 
+! surface.
+!    
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    LOGICAL, INTENT(IN)                  :: debut
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_sic
+
+
+! Local variables
+!****************************************************************************************
+    LOGICAL                     :: check=.FALSE.
+    INTEGER                     :: i
+    REAL                        :: zfra
+    REAL, PARAMETER             :: t_grnd=271.35
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_tmp
+    REAL, DIMENSION(klon)       :: soilcap, soilflux
+    REAL, DIMENSION(klon,nbsrf) :: pctsrf_lim
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! 1)    
+! Read from climatologie file SST and fraction of sub-surfaces
+!
+!****************************************************************************************
+    CALL interfoce_lim(itime, dtime, jour, & 
+         knon, knindex, &
+         debut, &
+         tsurf_tmp, pctsrf_lim)
+  
+    DO i = 1, knon
+       tsurf_tmp(i) = tsurf_in(i)
+       IF (pctsrf_lim(knindex(i),is_sic) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_tmp(i) = RTT - 1.8
+          IF (soil_model) tsoil(i,:) = RTT -1.8
+       ENDIF
+    ENDDO
+
+!****************************************************************************************
+! 2) 
+! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, 
+!                    dflux_s, dflux_l and qsurf
+!****************************************************************************************
+
+! calculate the parameters cal, beta, capsol and dif_grnd
+
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+    IF (soil_model) THEN 
+! update tsoil and calculate soilcap and soilflux
+       CALL soil(dtime, is_sic, knon,snow, tsurf_tmp, tsoil,soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+       dif_grnd = 1.0 / tau_gl
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+
+    beta = 1.0
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_tmp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!****************************************************************************************
+! 3)
+! Calculations due to snow and runoff
+!
+!****************************************************************************************
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_tmp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+    
+! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno)
+! 
+    CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:))  
+
+    WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0.
+
+    alb_new(:) = 0.0
+    DO i=1, knon
+       zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0)))
+       alb_new(i) = alb_neig(i) * zfra +  0.6 * (1.0-zfra)
+    ENDDO
+!!      alb_new(1 : knon) = 0.6
+
+!****************************************************************************************
+! 4)
+! Calculate tmp_flux_g
+!
+!****************************************************************************************
+!
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+!IM: faire dependre le coefficient de conduction de la glace de mer
+!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!    actuel correspond a 3m de glace de mer, cf. L.Li
+!
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_lim(knindex(i),is_sic) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * dif_grnd(i) *RCPD/cal(i)
+       
+    ENDDO
+
+!!$    z0_new = 0.002
+!!$    z0_new = SQRT(z0_new**2+rugoro**2)
+    alblw(1:knon) = alb_new(1:knon)
+
+!****************************************************************************************
+! 5)
+! Return the new values for the seaice fraction
+!
+!****************************************************************************************
+
+    pctsrf_sic(:) = pctsrf_lim(:,is_sic)
+
+  END SUBROUTINE ocean_forced_ice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_get_vars(flux_o, flux_g)
+! Get some variables from module oceanforced.
+! This subroutine returns variables to a external routine
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Initialize the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_forced_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_forced_mod
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_slab_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_slab_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ocean_slab_mod.F90	(revision 984)
@@ -0,0 +1,648 @@
+!
+! $Header$
+!
+MODULE ocean_slab_mod
+!
+! This module is used for both surface ocean and sea-ice when using the slab ocean,
+! "ocean=slab".
+!
+  USE surface_data,     ONLY : tau_gl, calice, calsno
+  USE fonte_neige_mod,  ONLY : fonte_neige
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE dimphy
+  
+  IMPLICIT NONE
+
+  INTEGER, PRIVATE, SAVE                           :: lmt_pas, julien, idayvrai
+  !$OMP THREADPRIVATE(lmt_pas,julien,idayvrai)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_seaice
+  !$OMP THREADPRIVATE(tmp_seaice)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_tslab_loc
+  !$OMP THREADPRIVATE(tmp_tslab_loc)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slab_bils
+  !$OMP THREADPRIVATE(slab_bils)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE , SAVE  :: lmt_bils
+  !$OMP THREADPRIVATE(lmt_bils)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tmp_pctsrf_slab
+  !$OMP THREADPRIVATE(tmp_pctsrf_slab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_tslab
+  !$OMP THREADPRIVATE(tmp_tslab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_radsol
+  !$OMP THREADPRIVATE(tmp_radsol)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+  LOGICAL, PRIVATE, SAVE                           :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_init(dtime, tslab_rst, seaice_rst, pctsrf_rst)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+
+! Input variables
+!****************************************************************************************
+    REAL, INTENT(IN)                         :: dtime
+! Variables read from restart file
+    REAL, DIMENSION(klon), INTENT(IN)        :: tslab_rst          
+    REAL, DIMENSION(klon), INTENT(IN)        :: seaice_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf_rst
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: error
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'ocean_slab_intit'
+
+
+    WRITE(lunout,*) '************************'
+    WRITE(lunout,*) 'SLAB OCEAN est actif, prenez precautions !'
+    WRITE(lunout,*) '************************'    
+
+! Allocate variables initialize from restart fields
+    ALLOCATE(tmp_tslab(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_tslab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_tslab(:) = tslab_rst(:)
+
+    ALLOCATE(tmp_tslab_loc(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_tslab_loc'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_tslab_loc(:) = tslab_rst(:)
+
+    ALLOCATE(tmp_seaice(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_seaice'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_seaice(:) = seaice_rst(:)
+
+    ALLOCATE(tmp_pctsrf_slab(klon,nbsrf), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_pctsrf_slab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_pctsrf_slab(:,:) = pctsrf_rst(:,:)
+    
+! Allocate some other variables internal in module mod_oceanslab
+    ALLOCATE(tmp_radsol(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_radsol'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! a mettre un slab_bils aussi en force !!!
+    ALLOCATE(slab_bils(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slab_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    slab_bils(:) = 0.0   
+
+    ALLOCATE(lmt_bils(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation lmt_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+
+! pour une lecture une fois par jour    
+    lmt_pas = NINT(86400./dtime * 1.0) 
+
+  END SUBROUTINE ocean_slab_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_noice( & 
+       dtime, knon, knindex, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, &
+       dflux_s, dflux_l, pctsrf_oce)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+    
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)   :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: i
+    REAL, DIMENSION(klon)  :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)  :: alb_neig, tsurf_temp
+
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_slab_noice'    
+
+    tsurf_new(1:knon) = tmp_tslab(knindex(1:knon))
+    pctsrf_oce(:)   = tmp_pctsrf_slab(:,is_oce)
+    
+    tsurf_temp(:) = tsurf_new(:)
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    tmp_flux_o(:) = 0.0
+    tmp_radsol(:) = 0.0
+
+    DO i=1, knon
+       tmp_radsol(knindex(i))=radsol(i)
+       
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) &
+            tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+    ENDDO
+    
+  END SUBROUTINE ocean_slab_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_ice(   &
+       itime, dtime, jour, knon, knindex, &
+       debut, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, &
+       alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+    LOGICAL, INTENT(IN)                  :: debut
+
+!In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)                :: alb_neig, tsurf_temp
+    REAL, DIMENSION(klon)                :: soilcap, soilflux
+    REAL, DIMENSION(klon)                :: zfra
+    REAL, PARAMETER                      :: t_grnd=271.35
+    REAL                                 :: amn, amx 
+    REAL, DIMENSION(klon)                :: tslab
+    REAL, DIMENSION(klon)                :: seaice ! glace de mer (kg/m2)
+    REAL, DIMENSION(klon,nbsrf)          :: pctsrf_new
+
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+! Initialization of output variables
+    alb_new(:) = 0.0
+
+!****************************************************************************************
+! 
+!
+!****************************************************************************************
+    IF ( ok_slab_sicOBS) THEN   
+       ! glace de mer observee, lecture conditions limites
+       CALL interfoce_lim(itime, dtime, jour, & 
+            knon, knindex, &
+            debut, &
+            tsurf_new, pctsrf_new)
+
+       tmp_pctsrf_slab(:,:) = pctsrf_new(:,:)
+       WRITE(lunout,*) 'jour lecture pctsrf_new sic =',jour
+
+    ELSE
+       pctsrf_new=tmp_pctsrf_slab
+    ENDIF
+
+    DO i = 1, knon
+       tsurf_new(i) = tsurf(i)
+       IF (pctsrf_new(knindex(i),is_sic) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_new(i) = RTT - 1.8
+          IF (soil_model) tsoil(i,:) = RTT -1.8
+       ENDIF
+    ENDDO
+    
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_sic, knon, snow, tsurf_new, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+    tsurf_temp = tsurf_new
+    beta = 1.0
+
+!****************************************************************************************
+!
+!
+!****************************************************************************************
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_temp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+!****************************************************************************************
+!     calcul albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & 
+         0.6 * (1.0-zfra(1:knon))
+    !!      alb_new(1 : knon) = 0.6
+
+!
+!IM: flux entre l'ocean et la glace de mer pour le "slab" ocean
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+!
+!IM: faire dependre le coefficient de conduction de la glace de mer
+!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!    actuel correspond a 3m de glace de mer, cf. L.Li
+!
+       IF ((cal(i).GT.1.0e-15) .AND. (pctsrf_new(knindex(i),is_sic) .GT. epsfra)) THEN
+          tmp_flux_g(knindex(i))=(tsurf_new(i)-t_grnd) &
+               * dif_grnd(i) *RCPD/cal(i)
+       ENDIF
+!
+!IM: Attention: ne pas initialiser le tmp_radsol puisque c'est deja fait sur is_oce;
+!IM:            tmp_radsol doit etre le flux solaire qui arrive sur l'ocean 
+!IM:            et non pas celui qui arrive sur la glace de mer
+    ENDDO
+    
+!
+! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean
+!
+
+    IF (check) THEN
+       amn=MIN(tmp_tslab(1),1000.)
+       amx=MAX(tmp_tslab(1),-1000.)
+       DO i=2, klon
+          amn=MIN(tmp_tslab(i),amn)
+          amx=MAX(tmp_tslab(i),amx)
+       ENDDO
+       
+       WRITE(lunout,*) ' debut avant interfoce_slab min max tmp_tslab',amn,amx
+    ENDIF !(check) THEN
+
+    tslab = tmp_tslab   
+
+    CALL interfoce_slab(klon, debut, itime, dtime, jour, &
+         tmp_radsol, tmp_flux_o, tmp_flux_g, tmp_pctsrf_slab, &
+         tslab, seaice, pctsrf_new)
+    
+    tmp_pctsrf_slab=pctsrf_new
+
+    DO i=1, knon
+       tmp_tslab(knindex(i))=tslab(knindex(i))
+    ENDDO
+     
+!!$    z0_new = 0.002
+!!$    z0_new = SQRT(z0_new**2+rugoro**2)
+    alblw(1:knon) = alb_new(1:knon)
+        
+!****************************************************************************************
+! Return the fraction of sea-ice
+! NB! jg : Peut-etre un probleme, faut-il prend aussi tmp_pctsrf_slab(:,is_oce)???
+!****************************************************************************************
+    pctsrf_sic(:) =  tmp_pctsrf_slab(:,is_sic)
+
+
+  END SUBROUTINE ocean_slab_ice
+! 
+!****************************************************************************************
+!
+  SUBROUTINE interfoce_slab(klon, debut, itap, dtime, ijour, &
+       radsol, fluxo, fluxg, pctsrf, &
+       tslab, seaice, pctsrf_slab)
+!
+! Cette routine calcule la temperature d'un slab ocean, la glace de mer 
+! et les pourcentages de la maille couverte par l'ocean libre et/ou 
+! la glace de mer pour un "slab" ocean de 50m
+!
+! Conception: Laurent Li
+! Re-ecriture + adaptation LMDZ4: I. Musat
+!
+! input:
+!   klon         nombre total de points de grille
+!   debut        logical: 1er appel a la physique
+!   itap         numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   ijour        jour dans l'annee en cours
+!   radsol       rayonnement net au sol (LW + SW)
+!   fluxo        flux turbulent (sensible + latent) sur les mailles oceaniques 
+!   fluxg        flux de conduction entre la surface de la glace de mer et l'ocean
+!   pctsrf       tableau des pourcentages de surface de chaque maille
+! output: 
+!   tslab        temperature de l'ocean libre
+!   seaice       glace de mer (kg/m2)
+!   pctsrf_slab  "pourcentages" (valeurs entre 0. et 1.) surfaces issus du slab
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: klon
+    LOGICAL, INTENT(IN)                       :: debut    ! not used
+    INTEGER, INTENT(IN)                       :: itap
+    REAL, INTENT(IN)                          :: dtime       ! not used
+    INTEGER, INTENT(IN)                       :: ijour
+    REAL, DIMENSION(klon), INTENT(IN)         :: radsol
+    REAL, DIMENSION(klon), INTENT(IN)         :: fluxo
+    REAL, DIMENSION(klon), INTENT(IN)         :: fluxg
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)  :: pctsrf
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tslab
+    REAL, DIMENSION(klon), INTENT(OUT)        :: seaice ! glace de mer (kg/m2)
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: pctsrf_slab
+
+! Local variables
+!****************************************************************************************
+    REAL                    :: amn, amx
+    REAL, PARAMETER         :: unjour=86400.
+    REAL, PARAMETER         :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K)
+    REAL, PARAMETER         :: cbing=0.334e+05        ! J/kg
+    REAL, DIMENSION(klon)   :: siceh !hauteur de la glace de mer (m)
+    INTEGER                 :: i
+    REAL                    :: zz, za, zb
+!
+!****************************************************************************************
+!
+    julien = MOD(ijour,360)
+
+    IF (check ) THEN
+       amn=MIN(tmp_tslab_loc(1),1000.)
+       amx=MAX(tmp_tslab_loc(1),-1000.)
+       DO i=2, klon
+          amn=MIN(tmp_tslab_loc(i),amn)
+          amx=MAX(tmp_tslab_loc(i),amx)
+       ENDDO
+
+       WRITE(lunout,*) ' debut min max tslab',amn,amx 
+       WRITE(lunout,*) ' itap,lmt_pas unjour',itap,lmt_pas,unjour
+    ENDIF
+
+    pctsrf_slab(1:klon,1:nbsrf) = pctsrf(1:klon,1:nbsrf)
+!
+! lecture du bilan au sol lmt_bils issu d'une simulation forcee en debut de journee
+! 
+    IF (MOD(itap,lmt_pas) .EQ. 1) THEN 
+       ! 1er pas de temps de la journee
+       idayvrai = ijour
+       CALL condsurf(julien,idayvrai, lmt_bils)
+    ENDIF
+
+    DO i = 1, klon
+       IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+            (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+!
+! fabriquer de la glace si congelation atteinte:
+!          
+          IF (tmp_tslab_loc(i).LT.(RTT-1.8)) THEN
+             zz =  (RTT-1.8)-tmp_tslab_loc(i)
+             tmp_seaice(i) = tmp_seaice(i) + cyang/cbing * zz
+             seaice(i) = tmp_seaice(i)
+             tmp_tslab_loc(i) = RTT-1.8
+          ENDIF
+!
+! faire fondre de la glace si temperature est superieure a 0:
+!
+          IF ((tmp_tslab_loc(i).GT.RTT) .AND. (tmp_seaice(i).GT.0.0)) THEN
+             zz = cyang/cbing * (tmp_tslab_loc(i)-RTT)
+             zz = MIN(zz,tmp_seaice(i))
+             tmp_seaice(i) = tmp_seaice(i) - zz
+             seaice(i) = tmp_seaice(i)
+             tmp_tslab_loc(i) = tmp_tslab_loc(i) - zz*cbing/cyang
+          ENDIF
+!
+! limiter la glace de mer a 10 metres (10000 kg/m2)
+!
+          IF(tmp_seaice(i).GT.45.) THEN
+             tmp_seaice(i) = MIN(tmp_seaice(i),10000.0)
+          ELSE
+             tmp_seaice(i) = 0. 
+          ENDIF
+          seaice(i) = tmp_seaice(i)
+          siceh(i)=tmp_seaice(i)/1000. !en metres
+!
+! determiner la nature du sol (glace de mer ou ocean libre):
+!
+! on fait dependre la fraction de seaice "pctsrf(i,is_sic)" 
+! de l'epaisseur de seaice :
+! pctsrf(i,is_sic)=1. si l'epaisseur de la glace de mer est >= a 20cm
+! et pctsrf(i,is_sic) croit lineairement avec seaice de 0. a 20cm d'epaisseur
+!
+
+          IF(.NOT.ok_slab_sicOBS) THEN
+             pctsrf_slab(i,is_sic)=MIN(siceh(i)/0.20, &
+                  1.-(pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)))
+             pctsrf_slab(i,is_oce)=1.0 - &
+                  (pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)+pctsrf_slab(i,is_sic))
+          ELSE
+             IF (i.EQ.1) WRITE(lunout,*) 'cas ok_slab_sicOBS TRUE : passe sur la modif.'
+          ENDIF !(.NOT.ok_slab_sicOBS) then
+       ENDIF !pctsrf
+    ENDDO
+!
+! Calculer le bilan du flux de chaleur au sol :
+!
+    DO i = 1, klon
+       za = radsol(i) + fluxo(i)
+       zb = fluxg(i)
+       IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+            (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+          slab_bils(i)=slab_bils(i)+(za*pctsrf_slab(i,is_oce) &
+               +zb*pctsrf_slab(i,is_sic))/ FLOAT(lmt_pas)
+       ENDIF
+    ENDDO !klon
+!
+! calcul tslab 
+!
+    IF (MOD(itap,lmt_pas).EQ.0) THEN !fin de journee
+!
+! calcul tslab 
+       amn=MIN(tmp_tslab_loc(1),1000.)
+       amx=MAX(tmp_tslab_loc(1),-1000.)
+       DO i = 1, klon
+          IF ((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+               (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+             tmp_tslab_loc(i) = tmp_tslab_loc(i) + &
+                  (slab_bils(i)-lmt_bils(i)) &
+                  /cyang*unjour
+
+! on remet l'accumulation a 0
+             slab_bils(i) = 0.
+          ENDIF !pctsrf
+!
+          IF (check) THEN
+             IF(i.EQ.1) THEN  
+                WRITE(lunout,*) 'i tmp_tslab_loc MOD(itap,lmt_pas).EQ.0 sicINTER',i,itap, &
+                     tmp_tslab_loc(i), tmp_seaice(i)
+             ENDIF
+             
+             amn=MIN(tmp_tslab_loc(i),amn)
+             amx=MAX(tmp_tslab_loc(i),amx)
+          ENDIF
+       ENDDO !klon
+    ENDIF !(MOD(itap,lmt_pas).EQ.0) THEN
+
+    IF ( check ) THEN
+       WRITE(lunout,*) 'fin min max tslab',amn,amx 
+    ENDIF
+
+    tslab  = tmp_tslab_loc
+    seaice = tmp_seaice
+
+  END SUBROUTINE interfoce_slab
+!
+!****************************************************************************************  
+!
+  SUBROUTINE ocean_slab_final(tslab_rst, seaice_rst)
+
+! This subroutine will send to phyredem the variables concerning the slab 
+! ocean that should be written to restart file.
+
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: tslab_rst
+    REAL, DIMENSION(klon), INTENT(OUT) :: seaice_rst
+
+!****************************************************************************************
+! Set the output variables
+    tslab_rst(:)  = tmp_tslab(:)
+!    tslab_rst(:)  = tmp_tslab_loc(:)
+    seaice_rst(:) = tmp_seaice(:)
+
+! Deallocation of all variables in module
+    DEALLOCATE(tmp_tslab, tmp_tslab_loc, tmp_pctsrf_slab)
+    DEALLOCATE(tmp_seaice, tmp_radsol, tmp_flux_o, tmp_flux_g)
+    DEALLOCATE(slab_bils, lmt_bils)
+
+  END SUBROUTINE ocean_slab_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_get_vars(tslab_loc, seaice_loc, flux_o_loc, flux_g_loc)
+! "Get some variables from module ocean_slab_mod"
+! This subroutine prints variables to a external routine
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: tslab_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: seaice_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g_loc
+
+! Set the output variables
+    tslab_loc(:)  = tmp_tslab(:)
+    seaice_loc(:) = tmp_seaice(:)
+    flux_o_loc(:) = tmp_flux_o(:)
+    flux_g_loc(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_slab_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_slab_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/orbite.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/orbite.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/orbite.F	(revision 984)
@@ -0,0 +1,325 @@
+!
+! $Header$
+!
+c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+c Objet: pour un jour donne, calculer la longitude vraie de la terre
+c        (par rapport au point vernal-21 mars) dans son orbite solaire
+c        calculer aussi la distance terre-soleil (unite astronomique)
+c======================================================================
+c Arguments:
+c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+c                  vernal (21 mars) en degres
+c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+c======================================================================
+#include "YOMCST.h"
+C
+C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)
+     .     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)
+     .     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)
+     .         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)
+     .         +13.0/12.0*xee*SIN(3.0*ranm)
+c
+      anv=ranv/pir
+      longi=anv+xl
+C
+      dist = (1-R_ecc*R_ecc)
+     .      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END
+c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+c======================================================================
+c Arguments:
+c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+c                   solaire a partir de l'equinoxe de printemps (degre)
+c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+c                   par 24 heures (unite en fraction de 0 a 1)
+c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+c                   la journee (0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+c
+      IF ( lat .GE. (pi_local/2.+lat_sun)
+     .    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)
+     .          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+c
+      frac(i) = omega / pi_local
+c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)
+     .          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,
+     s                  pmu0,frac)
+      USE dimphy
+      IMPLICIT none
+c=============================================================
+c Auteur : O. Boucher (LMD/CNRS)
+c          d'apres les routines zenith et angle de Z.X. Li 
+c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+c          connaissant la declinaison, la latitude et la longitude.
+c Rque   : Different de la routine angle en ce sens que zenang 
+c          fournit des moyennes de pmu0 et non des valeurs 
+c          instantanees, du coup frac prend toutes les valeurs 
+c          entre 0 et 1.
+c Date   : premiere version le 13 decembre 1994
+c          revu pour  GCM  le 30 septembre 1996
+c===============================================================
+c longi----INPUT : la longitude vraie de la terre dans son plan
+c                  solaire a partir de l'equinoxe de printemps (degre)
+c gmtime---INPUT : temps universel en fraction de jour
+c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+c lat------INPUT : latitude en degres
+c long-----INPUT : longitude en degres
+c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+c================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c================================================================
+      real longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+c omega : heure en radian du coucher de soleil 
+c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+c================================================================
+c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+c
+      DO i = 1, klon
+c
+      latr = lat(i) * pi_local / 180.
+c
+c--pose probleme quand lat=+/-90 degres
+c
+c      omega = -TAN(latr)*TAN(lat_sun)
+c      omega = ACOS(omega)
+c      IF (latr.GE.(pi_local/2.+lat_sun)
+c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+c         omega = 0.0       ! nuit polaire
+c      ENDIF
+c      IF (latr.GE.(pi_local/2.-lat_sun)
+c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+c         omega = pi_local  ! journee polaire
+c      ENDIF
+c
+c--remplace par cela (le cas par defaut est different)
+c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)
+     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.
+     .    latr.GT.(-pi_local/2.+lat_sun).AND.
+     .    latr.LT.(pi_local/2.-lat_sun).AND.
+     .    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega
+     .                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) + 
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)        
+      ENDIF
+c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+c
+c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)
+      ENDIF 
+c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +
+     .           COS(latr)*COS(lat_sun)*
+     .           (SIN(omegafin)-SIN(omegadeb))/
+     .           (omegafin-omegadeb)
+c
+      ENDIF
+c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+c
+      ENDIF   !---comparaison omega1 et omega2
+c
+      ENDDO
+c
+      END
+c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,
+     s                   pmu0, fract)
+      USE dimphy
+      IMPLICIT none
+c
+c Auteur(s): Z.X. Li (LMD/ENS)
+c
+c Objet: calculer le cosinus de l'angle zenithal du soleil en
+c        connaissant la declinaison du soleil, la latitude et la
+c        longitude du point sur la terre, et le temps universel
+c
+c Arguments d'entree:
+c     longi  : declinaison du soleil (en degres)
+c     gmtime : temps universel en second qui varie entre 0 et 86400
+c     lat    : latitude en degres
+c     long   : longitude en degres
+c Arguments de sortie:
+c     pmu0   : cosinus de l'angle zenithal
+c
+c====================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+c
+      incl=R_incl * zpir
+c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+c--initialisation a la nuit
+c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+c
+c 1 degre en longitude = 240 secondes en temps
+c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)
+     .           + cos(lat(n)*zpir) * cos(lat_sun)
+     .           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/orografi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/orografi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/orografi.F	(revision 984)
@@ -0,0 +1,1839 @@
+!
+! $Header$
+!
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature             
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG  .                +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG  .                +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE orodrag( nlon,nlev 
+     i                 , kgwd, kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+
+      USE dimphy
+      implicit none
+
+c
+c
+c**** *gwdrag* - does the gravity wave parametrization.
+c
+c     purpose.
+c     --------
+c
+c          this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves
+c
+c**   interface.
+c     ----------
+c          called from *callpar*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c      implicit logical (l)
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+c
+cym      integer nlon, nlev, klevm1
+      integer nlon, nlev
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(klon),
+     *      pvlow(klon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     $       ztauf(klon,klev+1),
+     *       zstab(klon,klev+1),
+     *       zvph(klon,klev+1),
+     *       zrho(klon,klev+1),
+     *       zri(klon,klev+1),
+     *       zpsi(klon,klev+1),
+     *       zzdep(klon,klev)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+cym      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+  200 continue
+c
+c
+c
+      call orosetup
+     *     ( nlon, ktest 
+     *     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress
+     *    ( nlon  , nlev
+     *    , ktest , icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic
+     *    , ztau 
+     *    , pgeom1,zdmod)
+c
+c
+c*         4.      compute stress profile.
+c*                 ------- ------ --------
+c
+  400 continue
+c
+c
+      call gwprofil
+     *       (  nlon , nlev
+     *       , kgwd   , kdx , ktest
+     *       , ikcrith, icrit
+     *       , paphm1, zrho   , zstab ,  zvph
+     *       , zri   , ztau   
+     *       , zdmod , psig  , pstd)
+c
+c
+c*         5.      compute tendencies.
+c*                 -------------------
+c
+  500 continue
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+      ilevp1=klev+1
+c
+c
+      do 524 jk=1,klev
+c
+c
+c     do 523 jl=1,kgwd
+c     ji=kdx(jl)
+c  Modif vectorisation 02/04/2004
+      do 523 ji=kidia,kfdia
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c controle des overshoots:
+c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c fin du controle des overshoots
+c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c simplement oppose au vent
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c  projection dans la direction de l'axe principal de l'orographie
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c     pte(ji,jk)=zdtdt(ji)
+c
+c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+c
+      pte(ji,jk)=0.0
+
+      endif
+  523 continue
+
+  524 continue
+c
+c
+      return
+      end
+      SUBROUTINE orosetup
+     *         ( nlon   , ktest
+     *         , kkcrit, kkcrith, kcrit
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgamma, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+c
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+c
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c
+c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c     print *,' entree gwsetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+c
+      zcons1=1./rd
+cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+c
+
+ 210  continue
+c
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define low-level flow
+c      ---------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define blocked flow
+c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+c
+c*******  setup orography axes and define plane of profiles  *******
+c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+c
+c  ************ define flow in plane of lowlevel stress *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c
+c*         2.2     brunt-vaisala frequency and density at half levels.
+c
+  220 continue
+c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*
+     *                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)
+     *                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+c
+c*         2.3     mean flow richardson number.
+c*                 and critical height for froude layer
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for the breaking
+c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,
+     *          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end
+      SUBROUTINE gwstress
+     *         (  nlon  , nlev
+     *         , ktest, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic  , ptau  
+     *         , pgeom1 , pdmod )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon, nlev
+      integer kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2
+     *    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+     *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+c
+      return
+      end
+      SUBROUTINE GWPROFIL
+     *         ( NLON, NLEV
+     *         , kgwd, kdx , ktest
+     *         , KKCRITH, KCRIT
+     *         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU
+     *         , pdmod   , psig , pvar)
+
+C**** *GWPROFIL*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *GWDRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD:
+C     -------
+C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+C     NONLINEAR GRAVITY WAVE BREAKING.
+C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+C     
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+C-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+C
+
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)
+     *       ,kdx(nlon) , ktest(nlon)
+
+C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),
+     *     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),
+     *     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)
+     
+      REAL pdmod (NLON) , psig(NLON),
+     *     pvar(NLON)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
+      REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
+      REAL ZTAU (KLON,KLEV+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+c      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      ilevh=KLEV/3
+C
+c     DO 400 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      DO 400 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+      endif
+  400 CONTINUE
+  
+C
+      DO 430 JK=KLEV,2,-1
+C
+C
+C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+C                 BLOCKING LAYER.
+  410 CONTINUE
+C
+c     DO 411 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 411 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+C          ENDIF
+C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+      endif
+ 411  CONTINUE             
+C
+C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+C        
+C
+C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+C
+  420 CONTINUE
+C
+c     DO 421 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 421 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)
+     *                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+      endif
+  421 CONTINUE
+C
+C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+C                 LEVEL
+C
+                          
+c     DO 431 ji=1,kgwd
+c     jl=Kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 431 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+      endif
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+c     DO 530 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+      endif
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+c     DO 532 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +
+     .                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*
+     .                ZDELP/ZDELPT
+     
+        ENDIF
+            
+      endif
+ 532  CONTINUE    
+ 
+C  REORGANISATION IN THE STRATOSPHERE
+
+c     DO 533 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+      endif
+ 533  CONTINUE
+
+C REORGANISATION IN THE TROPOSPHERE
+
+c      DO 534 ji=1,kgwd
+c      jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 534 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +
+     *                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP
+     .                                                     /ZDELPT
+
+       ENDIF
+      endif
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,      
+     e                   plat,pmea,pstd, ppic,
+     e                   ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL OROLIFT(klon,klev,ktest,
+     .            dtime,
+     .            papmh, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, ppic,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG .                 +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG .                 +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE OROLIFT( NLON,NLEV
+     I                 , KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PLAT
+     R                 , PMEA, PVAROR, ppic
+C OUTPUTS
+     R                 , PULOW,PVLOW
+     R                 , PVOM,PVOL,PTE )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+      USE dimphy
+      implicit none
+C
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),
+     *      PVOL(NLON,NLEV),
+     *      PVOM(NLON,NLEV),
+     *      PULOW(NLON),
+     *      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),
+     *      PVM1(NLON,NLEV),
+     *      PTM1(NLON,NLEV),
+     *      PLAT(NLON),PMEA(NLON),
+     *      PVAROR(NLON),
+     *      ppic(NLON),
+     *      PGEOM1(NLON,NLEV),
+     *      PAPHM1(NLON,NLEV+1)
+C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      logical lifthigh
+cym      integer klevm1, jl, ilevh, jk
+      integer  jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER  
+     *         IKNUB(klon),
+     *         IKNUL(klon)
+      LOGICAL LL1(KLON,KLEV+1)
+C
+      REAL   ZTAU(KLON,KLEV+1),
+     *       ZTAV(KLON,KLEV+1),
+     *       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),
+     *       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+C-----------------------------------------------------------------------
+C
+C*         1.1  INITIALIZATIONS
+C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)STOP
+      ZCONS1=1./RD
+cym      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+C     do 2011 jl=kidia,kfdia
+C     IF(KTEST(JL).EQ.1) THEN
+C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+C     ENDIF
+C2011 continue
+
+C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 223'
+
+C********************************************************************
+C
+C*     DEFINE LOW LEVEL FLOW
+C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)
+     *               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 CONTINUE
+C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      IF(LIFTHIGH)THEN
+C
+  500 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 500'
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END
+
+
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+c      USE parallel
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PSIG        : VERTICAL COORDINATE TABLE
+C        NLEV        : NUMBER OF MODEL LEVELS
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C        ECMWF Research Department documentation of the IFS
+C
+C     AUTHOR.
+C     -------
+C        MARTIN MILLER             *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01
+C     ------------------------------------------------------------------
+      implicit none
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+      integer nlon,nlev, jk
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+C
+C*       1.    SET THE VALUES OF THE PARAMETERS
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+      
+            
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+
+
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+C
+      GKLIFT=0.50  
+      GVCRIT =0.0
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=1.E-12
+C
+      GTSEC=1.E-07
+C
+C      ----------------------------------------------------------------
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ozonecm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ozonecm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ozonecm.F	(revision 984)
@@ -0,0 +1,89 @@
+!
+! $Header$
+!
+      SUBROUTINE ozonecm(rjour, rlat, paprs, o3)
+      USE dimphy
+      IMPLICIT none
+C
+C The ozone climatology is based on an analytic formula which fits the
+C Krueger and Mintzner (1976) profile, as well as the variations with
+C altitude and latitude of the maximum ozone concentrations and the total
+C column ozone concentration of Keating and Young (1986). The analytic
+C formula have been established by J-F Royer (CRNM, Meteo France), who
+C also provided us the code.
+C
+C A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the
+C 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976).
+C
+C Keating, G. M. and D. F. Young, 1985: Interim reference models for the
+C middle atmosphere, Handbook for MAP, vol. 16, 205-229.
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+#include "YOMCST.h"
+      REAL rlat(klon), paprs(klon,klev+1)
+      REAL o3(klon,klev)   ! ozone concentration in kg/kg
+      REAL tozon, rjour, pi, pl
+      INTEGER i, k
+C----------------------------------------------------------
+      REAL field(klon,klev+1)
+      REAL ps
+      PARAMETER (ps=101325.0)
+      REAL an, unit, zo3q3
+      SAVE an, unit, zo3q3
+c$OMP THREADPRIVATE(an, unit, zo3q3)
+      REAL mu,gms, zslat, zsint, zcost, z, ppm, qpm, a
+      REAL asec, bsec, aprim, zo3a3
+C----------------------------------------------------------
+c         data an /365.25/   (meteo)
+      DATA an /360.00/
+      DATA unit /2.1415e-05/
+      DATA zo3q3 /4.0e-08/
+
+      pi = 4.0 * ATAN(1.0)
+      DO k = 1, klev
+      DO i = 1, klon
+      zslat = SIN(pi/180.*rlat(i))
+      zsint = SIN(2.*pi*(rjour+15.)/an)
+      zcost = COS(2.*pi*(rjour+15.)/an)
+      z = 0.0531+zsint*(-0.001595+0.009443*zslat) +
+     .  zcost*(-0.001344-0.00346*zslat) +
+     .  zslat**2*(.056222+zslat**2*(-.037609
+     . +.012248*zsint+.00521*zcost+.008890*zslat))
+      zo3a3 = zo3q3/ps/2.
+      z = z-zo3q3*ps
+      gms = z
+      mu = ABS(sin(pi/180.*rlat(i)))
+      ppm = 800.-(500.*zslat+150.*zcost)*zslat
+      qpm = 1.74e-5-(7.5e-6*zslat+1.7e-6*zcost)*zslat
+      bsec = 2650.+5000.*zslat**2
+      a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
+      a = a/(bsec**(3./2.)+ppm**(3./2.))**2
+      aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
+      aprim = amax1(0.,aprim)
+      asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
+      asec = AMAX1(0.0,asec)
+      aprim = gms-asec/(1.+(bsec/ps)**(3./2.))
+      pl = paprs(i,k)
+      tozon = aprim/(1.+3.*(ppm/pl)**2)+asec/(1.+(bsec/pl)**(3./2.))
+     .  + zo3a3*pl*pl
+      tozon = tozon / 9.81  ! en kg/m**2
+      tozon = tozon / unit  ! en kg/m**2  > u dobson (10e-5 m)
+      tozon = tozon / 1000. ! en cm
+      field(i,k) = tozon
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         field(i,klev+1) = 0.0
+      ENDDO
+      DO k = 1, klev
+        DO i = 1, klon
+          o3(i,k) = field(i,k) - field(i,k+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/pbl_surface_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/pbl_surface_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/pbl_surface_mod.F90	(revision 984)
@@ -0,0 +1,1245 @@
+!
+! $Header$
+!
+MODULE pbl_surface_mod
+!
+! Planetary Boundary Layer and Surface module
+!
+! This module manage the calculation of turbulent diffusion in the boundary layer 
+! and all interactions towards the differents sub-surfaces.
+!
+!
+  USE dimphy
+  USE mod_phys_lmdz_para,  ONLY : mpi_size
+  USE ioipsl
+  USE surface_data,        ONLY : ocean, ok_veget
+  USE surf_land_mod,       ONLY : surf_land
+  USE surf_landice_mod,    ONLY : surf_landice
+  USE surf_ocean_mod,      ONLY : surf_ocean
+  USE surf_seaice_mod,     ONLY : surf_seaice
+  USE cpl_mod,             ONLY : gath2cpl
+  USE climb_hq_mod,        ONLY : climb_hq_down, climb_hq_up
+  USE climb_wind_mod,      ONLY : climb_wind_down, climb_wind_up
+  USE coef_diff_turb_mod,  ONLY : coef_diff_turb
+
+  IMPLICIT NONE
+
+! Declaration of variables saved in restart file
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: qsol
+  !$OMP THREADPRIVATE(qsol)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: fder
+  !$OMP THREADPRIVATE(fder)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: snow
+  !$OMP THREADPRIVATE(snow)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: qsurf
+  !$OMP THREADPRIVATE(qsurf)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: evap
+  !$OMP THREADPRIVATE(evap)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: rugos
+  !$OMP THREADPRIVATE(rugos)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: agesno
+  !$OMP THREADPRIVATE(agesno)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: ftsoil  
+  !$OMP THREADPRIVATE(ftsoil)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,&
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+! This routine should be called after the restart file has been read.
+! This routine initialize the restart variables and does some validation tests
+! for the index of the different surfaces and tests the choice of type of ocean.
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "iniprint.h"
+ 
+! 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
+
+  
+! Local variables
+!****************************************************************************************
+    INTEGER                       :: ierr
+    CHARACTER(len=80)             :: abort_message
+    CHARACTER(len = 20)           :: modname = 'pbl_surface_init'
+    
+
+!****************************************************************************************
+! Allocate and initialize module variables with fields read from restart file.
+!
+!****************************************************************************************    
+    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)
+
+    ALLOCATE(snow(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(qsurf(klon,nbsrf), stat=ierr)
+    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(:,:,:)
+
+
+!****************************************************************************************
+! Test for sub-surface indices
+!
+!****************************************************************************************
+    IF (is_ter /= 1) THEN 
+      WRITE(lunout,*)" *** Warning ***"
+      WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter
+      WRITE(lunout,*)"or on doit commencer par les surfaces continentales"
+      abort_message="voir ci-dessus"
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_oce > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' l''ocean doit etre traite avant la banquise'
+      WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_lic > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer'
+      WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Validation of ocean mode
+!
+!****************************************************************************************
+
+    IF (ocean /= 'slab  ' .AND. ocean /= 'force ' .AND. ocean /= 'couple') THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)'Option couplage pour l''ocean = ', ocean
+      abort_message='option pour l''ocean non valable'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Test of coherence between variable ok_veget and cpp key CPP_VEGET
+!
+!****************************************************************************************
+    IF (ok_veget) THEN
+#ifndef CPP_VEGET
+       abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.'
+       CALL abort_gcm(modname,abort_message,1)
+#endif
+    ENDIF
+
+
+  END SUBROUTINE pbl_surface_init
+!  
+!****************************************************************************************
+!  
+
+  SUBROUTINE pbl_surface( &
+       dtime,     date0,     itap,     jour,          &
+       debut,     lafin,                              &
+       rlon,      rlat,      rugoro,   rmu0,          &
+       rain_f,    snow_f,    solsw_m,  sollw_m,       &
+       t,         q,         u,        v,             &
+       pplay,     paprs,     pctsrf,                  &
+       ts,        albe,      alblw,    u10m,   v10m,  &
+       sollwdown, cdragh,    cdragm,   zu1,    zv1,   &
+       albsol,    albsollw,  zxsens,   zxevap,        &
+       zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
+       d_t,       d_q,       d_u,      d_v,           & 
+       zcoefh,    pctsrf_new,                         &
+       qsol_d,    zq2m,      s_pblh,   s_plcl,        &
+       s_capCL,   s_oliqCL,  s_cteiCL, s_pblT,        &
+       s_therm,   s_trmb1,   s_trmb2,  s_trmb3,       &
+       zxrugs,    zu10m,     zv10m,    fder_print,    &
+       zxqsurf,   rh2m,      zxfluxu,  zxfluxv,       &
+       rugos_d,   agesno_d,  sollw,    solsw,         &
+       d_ts,      evap_d,    fluxlat,  t2m,           &
+       wfbils,    wfbilo,    flux_t,   flux_u, flux_v,&
+       dflux_t,   dflux_q,   zxsnow,                  &
+       zxfluxt,   zxfluxq,   q2m,      flux_q )
+!****************************************************************************************
+! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+! Objet: interface de "couche limite" (diffusion verticale)
+!
+!AA REM:
+!AA-----
+!AA Tout ce qui a trait au traceurs est dans phytrac maintenant
+!AA pour l'instant le calcul de la couche limite pour les traceurs
+!AA se fait avec cltrac et ne tient pas compte de la differentiation
+!AA des sous-fraction de sol.
+!AA REM bis :
+!AA----------
+!AA Pour pouvoir extraire les coefficient d'echanges et le vent 
+!AA dans la premiere couche, 3 champs supplementaires ont ete crees
+!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
+!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir 
+!AA si les informations des subsurfaces doivent etre prises en compte
+!AA il faudra sortir ces memes champs en leur ajoutant une dimension, 
+!AA c'est a dire nbsrf (nbre de subsurface).
+!
+! Arguments:
+!
+! dtime----input-R- interval du temps (secondes)
+! itap-----input-I- numero du pas de temps
+! date0----input-R- jour initial
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! ts-------input-R- temperature du sol (en Kelvin)
+! paprs----input-R- pression a intercouche (Pa)
+! pplay----input-R- pression au milieu de couche (Pa)
+! rlat-----input-R- latitude en degree
+! rugos----input-R- longeur de rugosite (en m)
+!
+! d_t------output-R- le changement pour "t"
+! d_q------output-R- le changement pour "q"
+! d_u------output-R- le changement pour "u"
+! d_v------output-R- le changement pour "v"
+! d_ts-----output-R- le changement pour "ts"
+! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)
+!                    (orientation positive vers le bas)
+! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
+! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
+! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
+! dflux_t--output-R- derive du flux sensible
+! dflux_q--output-R- derive du flux latent
+! zu1------output-R- le vent dans la premiere couche
+! zv1------output-R- le vent dans la premiere couche
+! trmb1----output-R- deep_cape
+! trmb2----output-R- inhibition 
+! trmb3----output-R- Point Omega
+! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL
+! plcl-----output-R- Niveau de condensation
+! pblh-----output-R- HCL
+! pblT-----output-R- T au nveau HCL
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+    INCLUDE "dimensions.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "temps.h"
+    INCLUDE "control.h"
+
+! Input variables
+!****************************************************************************************
+    REAL,                         INTENT(IN)        :: dtime
+    REAL,                         INTENT(IN)        :: date0
+    INTEGER,                      INTENT(IN)        :: itap
+    INTEGER,                      INTENT(IN)        :: jour    ! jour de l'annee en cours
+    LOGICAL,                      INTENT(IN)        :: debut, lafin
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rmu0    ! cosinus de l'angle solaire zenithal
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rain_f, snow_f
+    REAL, DIMENSION(klon),        INTENT(IN)        :: solsw_m ! mean value
+    REAL, DIMENSION(klon),        INTENT(IN)        :: sollw_m ! mean value
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: t, q
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: u, v
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: pplay
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)        :: paprs
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)        :: pctsrf
+
+! Input/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: ts
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: albe
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alblw
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: u10m, v10m
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: sollwdown
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: cdragh, cdragm
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu1
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: albsol
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: albsollw
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxsens, zxevap
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxtsol
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxfluxlat
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zt2m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsat2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_t, d_q
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_u, d_v
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zcoefh
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: pctsrf_new
+
+! Output only for diagnostics
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol_d
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zq2m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblh
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_plcl
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_capCL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_oliqCL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_cteiCL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblT
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_therm
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb1
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb2
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb3
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxrugs
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu10m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv10m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: fder_print
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxqsurf
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: rh2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxu, zxfluxv
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: rugos_d
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: agesno_d
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: sollw, solsw
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: d_ts
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: evap_d
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: fluxlat
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: t2m
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: wfbils, wfbilo
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u, flux_v
+
+! Output not needed
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: dflux_t, dflux_q
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: zxsnow
+    REAL, DIMENSION(klon, klev), INTENT(OUT)        :: zxfluxt, zxfluxq
+    REAL, DIMENSION(klon, nbsrf),INTENT(OUT)        :: q2m
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q
+
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER, SAVE                            :: nhoridbg, nidbg
+!$OMP THREADPRIVATE(nhoridbg, nidbg)
+    LOGICAL, SAVE                            :: debugindex=.FALSE.
+!$OMP THREADPRIVATE(debugindex)
+    LOGICAL, SAVE                            :: first_call=.TRUE.
+!$OMP THREADPRIVATE(first_call)
+    CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf
+!$OMP THREADPRIVATE(cl_surf)
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                            :: i, k, nsrf 
+    INTEGER                            :: knon, j
+    INTEGER                            :: idayref
+    INTEGER , DIMENSION(klon)          :: ni
+    REAL                               :: zx_alf1, zx_alf2 !valeur ambiante par extrapola
+    REAL                               :: amn, amx
+    REAL, DIMENSION(klon)              :: r_co2_ppm     ! taux CO2 atmosphere
+    REAL, DIMENSION(klon)              :: yts, yrugos, ypct, yz0_new
+    REAL, DIMENSION(klon)              :: yalb
+    REAL, DIMENSION(klon)              :: yalblw
+    REAL, DIMENSION(klon)              :: yu1, yv1
+    REAL, DIMENSION(klon)              :: ysnow, yqsurf, yagesno, yqsol
+    REAL, DIMENSION(klon)              :: yrain_f, ysnow_f
+    REAL, DIMENSION(klon)              :: ysollw, ysolsw, ysollwdown
+    REAL, DIMENSION(klon)              :: yfder
+    REAL, DIMENSION(klon)              :: yrads,yrugoro
+    REAL, DIMENSION(klon)              :: yfluxlat
+    REAL, DIMENSION(klon)              :: y_d_ts
+    REAL, DIMENSION(klon)              :: y_flux_t1, y_flux_q1
+    REAL, DIMENSION(klon)              :: y_dflux_t, y_dflux_q
+    REAL, DIMENSION(klon)              :: u1lay, v1lay
+    REAL, DIMENSION(klon)              :: yt2m, yq2m, yu10m
+    REAL, DIMENSION(klon)              :: yustar
+    REAL, DIMENSION(klon)              :: yu10mx
+    REAL, DIMENSION(klon)              :: yu10my
+    REAL, DIMENSION(klon)              :: ywindsp
+    REAL, DIMENSION(klon)              :: yt10m, yq10m
+    REAL, DIMENSION(klon)              :: ypblh
+    REAL, DIMENSION(klon)              :: ylcl
+    REAL, DIMENSION(klon)              :: ycapCL
+    REAL, DIMENSION(klon)              :: yoliqCL
+    REAL, DIMENSION(klon)              :: ycteiCL
+    REAL, DIMENSION(klon)              :: ypblT
+    REAL, DIMENSION(klon)              :: ytherm
+    REAL, DIMENSION(klon)              :: ytrmb1
+    REAL, DIMENSION(klon)              :: ytrmb2
+    REAL, DIMENSION(klon)              :: ytrmb3
+    REAL, DIMENSION(klon)              :: uzon, vmer
+    REAL, DIMENSION(klon)              :: tair1, qair1, tairsol
+    REAL, DIMENSION(klon)              :: psfce, patm
+    REAL, DIMENSION(klon)              :: qairsol, zgeo1
+    REAL, DIMENSION(klon)              :: rugo1
+    REAL, DIMENSION(klon)              :: yfluxsens, swdown
+    REAL, DIMENSION(klon)              :: petAcoef, peqAcoef, petBcoef, peqBcoef
+    REAL, DIMENSION(klon)              :: ypsref, epot_air
+    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb_new
+    REAL, DIMENSION(klon)              :: pctsrf_nsrf
+    REAL, DIMENSION(klon)              :: ztsol
+    REAL, DIMENSION(klon,klev)         :: y_d_t, y_d_q
+    REAL, DIMENSION(klon,klev)         :: y_d_u, y_d_v
+    REAL, DIMENSION(klon,klev)         :: y_flux_t, y_flux_q
+    REAL, DIMENSION(klon,klev)         :: y_flux_u, y_flux_v
+    REAL, DIMENSION(klon,klev)         :: ycoefh, ycoefm
+    REAL, DIMENSION(klon,klev)         :: yu, yv
+    REAL, DIMENSION(klon,klev)         :: yt, yq
+    REAL, DIMENSION(klon,klev)         :: ypplay, ydelp
+    REAL, DIMENSION(klon,klev)         :: delp
+    REAL, DIMENSION(klon,klev+1)       :: ypaprs
+    REAL, DIMENSION(klon,nsoilmx)      :: ytsoil
+    REAL, DIMENSION(klon,nbsrf)        :: pctsrf_pot
+    CHARACTER(len=80)                  :: abort_message
+    CHARACTER(len=20)                  :: modname = 'pbl_surface'
+    LOGICAL, PARAMETER                 :: zxli=.FALSE. ! utiliser un jeu de fonctions simples
+    LOGICAL, PARAMETER                 :: check=.FALSE.
+
+! For debugging with IOIPSL
+    INTEGER, DIMENSION(iim*(jjm+1))    :: ndexbg
+    REAL                               :: zjulian
+    REAL, DIMENSION(klon)              :: tabindx
+    REAL, DIMENSION(iim,jjm+1)         :: zx_lon, zx_lat
+    REAL, DIMENSION(iim,jjm+1)         :: debugtab
+
+
+    REAL, DIMENSION(klon,nbsrf)        :: pblh
+    REAL, DIMENSION(klon,nbsrf)        :: plcl
+    REAL, DIMENSION(klon,nbsrf)        :: capCL
+    REAL, DIMENSION(klon,nbsrf)        :: oliqCL
+    REAL, DIMENSION(klon,nbsrf)        :: cteiCL
+    REAL, DIMENSION(klon,nbsrf)        :: pblT
+    REAL, DIMENSION(klon,nbsrf)        :: therm
+    REAL, DIMENSION(klon,nbsrf)        :: trmb1
+    REAL, DIMENSION(klon,nbsrf)        :: trmb2
+    REAL, DIMENSION(klon,nbsrf)        :: trmb3
+    REAL, DIMENSION(klon,nbsrf)        :: zx_rh2m, zx_qsat2m
+    REAL, DIMENSION(klon,nbsrf)        :: zx_qs1, zx_t1
+    REAL, DIMENSION(klon,nbsrf)        :: zdelta1, zcor1
+
+
+!****************************************************************************************
+! End of declarations
+!****************************************************************************************
+
+
+!****************************************************************************************
+! 1) Initialisation and validation tests 
+!    Only done first time entering this subroutine
+!
+!****************************************************************************************
+
+
+    IF (first_call) THEN
+       first_call=.FALSE.
+      
+       ! Initilize debug IO
+       IF (debugindex .AND. mpi_size==1) THEN 
+          ! initialize IOIPSL output
+          idayref = day_ini
+          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+          DO i = 1, iim
+             zx_lon(i,1) = rlon(i+1)
+             zx_lon(i,jjm+1) = rlon(i+1)
+          ENDDO
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+          CALL histbeg("sous_index", iim,zx_lon(:,1),jjm+1,zx_lat(1,:), &
+               1,iim,1,jjm+1, &
+               itau_phy,zjulian,dtime,nhoridbg,nidbg) 
+          ! no vertical axis
+          cl_surf(1)='ter'
+          cl_surf(2)='lic'
+          cl_surf(3)='oce'
+          cl_surf(4)='sic'
+          DO nsrf=1,nbsrf
+             CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim, &
+                  jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) 
+          END DO
+
+          CALL histend(nidbg)
+          CALL histsync(nidbg)
+
+       END IF
+       
+    ENDIF
+          
+!****************************************************************************************
+! 2) Initialization to zero 
+!    Done for all local variables that will be compressed later
+!    and argument with INTENT(OUT)
+!****************************************************************************************
+    cdragh = 0.0  ; cdragm = 0.0     ; dflux_t = 0.0   ; dflux_q = 0.0
+    ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0     ; zu1 = 0.0        
+    zv1 = 0.0     ; yqsurf = 0.0     ; yalb = 0.0      ; yalblw = 0.0    
+    yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0    
+    ysollw = 0.0  ; ysollwdown = 0.0 ; yrugos = 0.0    ; yu1 = 0.0    
+    yv1 = 0.0     ; yrads = 0.0      ; ypaprs = 0.0    ; ypplay = 0.0
+    ydelp = 0.0   ; yu = 0.0         ; yv = 0.0        ; yt = 0.0         
+    yq = 0.0      ; pctsrf_new = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0 
+    yrugoro = 0.0 ; yu10mx = 0.0     ; yu10my = 0.0    ; ywindsp = 0.0   
+    d_ts = 0.0    ; yfluxlat=0.0     ; flux_t = 0.0    ; flux_q = 0.0     
+    flux_u = 0.0  ; flux_v = 0.0     ; d_t = 0.0       ; d_q = 0.0      
+    d_u = 0.0     ; d_v = 0.0        ; zcoefh = 0.0    ; yqsol = 0.0    
+    ytherm = 0.0
+     
+    ytsoil = 999999. 
+
+!****************************************************************************************
+! 3) - Calculate pressure thickness of each layer
+!    - Calculate the wind at first layer
+!
+!****************************************************************************************
+    DO k = 1, klev
+       DO i = 1, klon
+          delp(i,k) = paprs(i,k)-paprs(i,k+1)
+       ENDDO
+    ENDDO
+    DO i = 1, klon
+       zx_alf1 = 1.0
+       zx_alf2 = 1.0 - zx_alf1
+       u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2
+       v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2
+    ENDDO
+
+
+!****************************************************************************************
+! Test for rugos........ from physiq.. A la fin plutot???
+! Calcul de l'abedo moyen par maille
+!****************************************************************************************
+
+    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)
+       ENDDO
+    ENDDO
+
+! Calcul de l'abedo moyen par maille
+    albsol(:)   = 0.0
+    albsollw(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          albsol(i)   = albsol(i)   + albe(i,nsrf)  * pctsrf(i,nsrf)
+          albsollw(i) = albsollw(i) + alblw(i,nsrf) * pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+
+
+
+! Calcule de ztsol (aussi fait dans physiq.F, pourrait etre un argument)
+    ztsol(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+
+
+! Repartition du longwave par sous-surface linearisee
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf))
+          solsw(i,nsrf) = solsw_m(i)*(1.-albe(i,nsrf))/(1.-albsol(i))
+       ENDDO
+    ENDDO
+
+
+    DO i = 1, klon
+       sollwdown(i) = sollw_m(i) + RSIGMA*ztsol(i)**4
+    ENDDO
+
+!****************************************************************************************
+! 4) Loop over different surfaces
+!
+! All points with a possibility of the current surface are used. This is done
+! to allow the sea-ice to appear or disappear. It is considered here that the 
+! entier domaine of the ocean possibly can contain sea-ice.
+! 
+!****************************************************************************************
+
+    pctsrf_pot = pctsrf
+    pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+    pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+      
+    loop_nbsrf: DO nsrf = 1, nbsrf
+
+! Search for index(ni) and size(knon) of domaine to treat
+       ni(:) = 0
+       knon  = 0
+       DO i = 1, klon
+          IF (pctsrf_pot(i,nsrf).GT.epsfra) THEN
+             knon = knon + 1
+             ni(knon) = i
+          ENDIF
+       ENDDO
+
+       ! write index, with IOIPSL
+       IF (debugindex .AND. mpi_size==1) THEN 
+          tabindx(:)=0.
+          DO i=1,knon
+             tabindx(i)=FLOAT(i)
+          END DO
+          debugtab(:,:) = 0.
+          ndexbg(:) = 0
+          CALL gath2cpl(tabindx,debugtab,knon,ni)
+          CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1), ndexbg)
+       ENDIF
+       
+!****************************************************************************************
+! 5) Compress variables 
+!
+!****************************************************************************************
+
+       DO j = 1, knon
+          i = ni(j)
+          ypct(j) = pctsrf(i,nsrf)
+          yts(j) = ts(i,nsrf)
+          ysnow(j) = snow(i,nsrf)
+          yqsurf(j) = qsurf(i,nsrf)
+          yalb(j) = albe(i,nsrf)
+          yalblw(j) = alblw(i,nsrf)
+          yrain_f(j) = rain_f(i)
+          ysnow_f(j) = snow_f(i)
+          yagesno(j) = agesno(i,nsrf)
+          yfder(j) = fder(i)
+          ysolsw(j) = solsw(i,nsrf)
+          ysollw(j) = sollw(i,nsrf)
+          ysollwdown(j) = sollwdown(i)
+          yrugos(j) = rugos(i,nsrf)
+          yrugoro(j) = rugoro(i)
+          yu1(j) = u1lay(i)
+          yv1(j) = v1lay(i)
+          yrads(j) =  ysolsw(j)+ ysollw(j)
+          ypaprs(j,klev+1) = paprs(i,klev+1)
+          yu10mx(j) = u10m(i,nsrf)
+          yu10my(j) = v10m(i,nsrf)
+          ywindsp(j) = SQRT(yu10mx(j)*yu10mx(j) + yu10my(j)*yu10my(j) )
+       END DO
+
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ypaprs(j,k) = paprs(i,k)
+             ypplay(j,k) = pplay(i,k)
+             ydelp(j,k) = delp(i,k)
+             yu(j,k) = u(i,k)
+             yv(j,k) = v(i,k)
+             yt(j,k) = t(i,k)
+             yq(j,k) = q(i,k)
+          ENDDO
+       ENDDO
+       
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ytsoil(j,k) = ftsoil(i,k,nsrf)
+          END DO
+       END DO
+       
+       ! qsol(water height in soil) only for bucket continental model
+       IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             yqsol(j) = qsol(i)
+          END DO
+       ENDIF
+       
+!****************************************************************************************
+! 6) Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+!    atmosphere and coefficients for turbulent diffusion at surface(Cdrag).
+!
+!****************************************************************************************
+
+       CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
+            ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf,  &
+            ycoefm, ycoefh)
+       
+!****************************************************************************************
+! 
+! 8) "La descente" - "The downhill"
+!  
+!  climb_hq_down and climb_wind_down calculate the coefficients
+!  Ccoef_X et Dcoef_X for X=[H, Q, U, V].
+!  Only the coefficients at surface for H and Q are returned.
+!
+!****************************************************************************************
+
+! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q 
+       CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, &
+            ydelp, yt, yq, dtime, &
+            petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V
+       CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv)
+      
+
+!****************************************************************************************
+! 9) Small calculations
+!
+!****************************************************************************************
+          
+       ypsref(:) = ypaprs(:,1)  
+       epot_air(:) = 0.0
+       epot_air(1:knon) = RCPD*yt(1:knon,1)*(ypsref(1:knon)/ypplay(1:knon,1))**RKAPPA
+
+       swdown(:) = 0.0
+       IF (nsrf .EQ. is_ter) THEN 
+          swdown(1:knon) = ysolsw(1:knon)/(1-yalb(1:knon)) 
+       ELSE 
+          swdown(1:knon) = ysolsw(1:knon)
+       ENDIF
+
+       ! constant CO2
+       r_co2_ppm(:) = co2_ppm
+
+!****************************************************************************************
+!
+! 10) Switch selon current surface
+!     It is necessary to start with the continental surfaces because the ocean
+!     needs their run-off.
+!
+!****************************************************************************************
+       SELECT CASE(nsrf)
+     
+       CASE(is_ter)
+          CALL surf_land(itap, dtime, date0, jour, knon, ni,&
+               rlon, rlat, &
+               debut, lafin, ydelp(:,1), epot_air, r_co2_ppm, ysollwdown, ysolsw, swdown, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, & 
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+     
+       CASE(is_lic)
+          CALL surf_landice(itap, dtime, knon, ni, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+       CASE(is_oce)
+          CALL surf_ocean(rlon, rlat, ysollw, yalb, &
+               yrugos, ywindsp, rmu0, & 
+               yfder, &
+               itap, dtime, jour, knon, ni, &
+               debut, swdown, &
+               ypplay(:,1), ycoefh(:,1), ycoefm(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yagesno, &
+               yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+       CASE(is_sic)
+          CALL surf_seaice( &
+               rlon, rlat, ysollw, yalb, &
+               yfder, &
+               itap, dtime, jour, knon, ni, &
+               debut, lafin, swdown, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+
+       CASE DEFAULT
+          WRITE(lunout,*) 'Surface index = ', nsrf
+          abort_message = 'Surface index not valid'
+          CALL abort_gcm(modname,abort_message,1)
+       END SELECT
+
+!****************************************************************************************
+! Save the fraction of this sub-surface 
+!
+!****************************************************************************************
+       pctsrf_new(:,nsrf) = pctsrf_nsrf(:)
+
+!****************************************************************************************
+! 11) - Calcul the increment of surface temperature
+!     - Update albedo
+!
+!****************************************************************************************
+       y_d_ts(1:knon)   = ytsurf_new(1:knon) - yts(1:knon)
+ 
+       yalb(1:knon) = yalb_new(1:knon)
+
+!****************************************************************************************
+!
+! 12) "La remontee" - "The uphill"
+!
+!  The fluxes (y_flux_X) and tendancy (y_d_X) are calculated 
+!  for X=H, Q, U and V, for all vertical levels.
+!
+!****************************************************************************************
+! H and Q
+       y_flux_t1(:) =  yfluxsens(:)
+       y_flux_q1(:) = -yevap(:)
+
+       CALL climb_hq_up(knon, dtime, yt, yq, &
+            y_flux_q1, y_flux_t1, ypaprs, ypplay, &
+            y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:))    
+       
+! U and V
+       CALL climb_wind_up(knon, dtime, yu, yv, &
+            y_flux_u, y_flux_v, y_d_u, y_d_v)
+
+       DO j = 1, knon
+          y_dflux_t(j) = y_dflux_t(j) * ypct(j)
+          y_dflux_q(j) = y_dflux_q(j) * ypct(j)
+          yu1(j) = yu1(j) *  ypct(j)
+          yv1(j) = yv1(j) *  ypct(j)
+       ENDDO
+
+!****************************************************************************************
+! 13) Transform variables for output format : 
+!     - Decompress
+!     - Multiply with pourcentage of current surface
+!     - Cumulate in global variable
+!
+!****************************************************************************************
+
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ycoefh(j,k) = ycoefh(j,k) * ypct(j)
+             ycoefm(j,k) = ycoefm(j,k) * ypct(j)
+             y_d_t(j,k) = y_d_t(j,k) * ypct(j)
+             y_d_q(j,k) = y_d_q(j,k) * ypct(j)
+             y_d_u(j,k) = y_d_u(j,k) * ypct(j)
+             y_d_v(j,k) = y_d_v(j,k) * ypct(j)
+
+             flux_t(i,k,nsrf) = y_flux_t(j,k)
+             flux_q(i,k,nsrf) = y_flux_q(j,k)
+             flux_u(i,k,nsrf) = y_flux_u(j,k)
+             flux_v(i,k,nsrf) = y_flux_v(j,k)
+          ENDDO
+       ENDDO
+       
+       evap(:,nsrf) = - flux_q(:,1,nsrf)
+       
+       albe(:, nsrf) = 0.
+       alblw(:, nsrf) = 0.
+       snow(:, nsrf) = 0.
+       qsurf(:, nsrf) = 0.
+       rugos(:, nsrf) = 0.
+       fluxlat(:,nsrf) = 0.
+       DO j = 1, knon
+          i = ni(j)
+          d_ts(i,nsrf) = y_d_ts(j)
+          albe(i,nsrf) = yalb(j)  
+          alblw(i,nsrf) = yalblw(j)
+          snow(i,nsrf) = ysnow(j)  
+          qsurf(i,nsrf) = yqsurf(j)
+          rugos(i,nsrf) = yz0_new(j)
+          fluxlat(i,nsrf) = yfluxlat(j)
+          agesno(i,nsrf) = yagesno(j)  
+          cdragh(i) = cdragh(i) + ycoefh(j,1)
+          cdragm(i) = cdragm(i) + ycoefm(j,1)
+          dflux_t(i) = dflux_t(i) + y_dflux_t(j)
+          dflux_q(i) = dflux_q(i) + y_dflux_q(j)
+          zu1(i) = zu1(i) + yu1(j)
+          zv1(i) = zv1(i) + yv1(j)
+       END DO
+
+       IF ( nsrf .EQ. is_ter ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             qsol(i) = yqsol(j)
+          END DO
+       END IF
+       
+       ftsoil(:,:,nsrf) = 0.
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ftsoil(i, k, nsrf) = ytsoil(j,k)
+          END DO
+       END DO
+       
+       
+#ifdef CRAY
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+#else
+       DO j = 1, knon
+          i = ni(j)
+          DO k = 1, klev
+#endif
+             d_t(i,k) = d_t(i,k) + y_d_t(j,k)
+             d_q(i,k) = d_q(i,k) + y_d_q(j,k)
+             d_u(i,k) = d_u(i,k) + y_d_u(j,k)
+             d_v(i,k) = d_v(i,k) + y_d_v(j,k)
+             zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)
+#ifdef CRAY
+          END DO
+       END DO
+#else
+          END DO
+       END DO
+#endif
+
+!****************************************************************************************
+! 14) Calculate the temperature et relative humidity at 2m and the wind at 10m 
+!     Call HBTM
+!
+!****************************************************************************************
+       t2m(:,nsrf)    = 0.
+       q2m(:,nsrf)    = 0.
+       u10m(:,nsrf)   = 0.
+       v10m(:,nsrf)   = 0.
+
+       pblh(:,nsrf)   = 0.        ! Hauteur de couche limite
+       plcl(:,nsrf)   = 0.        ! Niveau de condensation de la CLA
+       capCL(:,nsrf)  = 0.        ! CAPE de couche limite
+       oliqCL(:,nsrf) = 0.        ! eau_liqu integree de couche limite
+       cteiCL(:,nsrf) = 0.        ! cloud top instab. crit. couche limite
+       pblt(:,nsrf)   = 0.        ! T a la Hauteur de couche limite
+       therm(:,nsrf)  = 0.
+       trmb1(:,nsrf)  = 0.        ! deep_cape
+       trmb2(:,nsrf)  = 0.        ! inhibition 
+       trmb3(:,nsrf)  = 0.        ! Point Omega
+
+#undef T2m     
+#define T2m     
+#ifdef T2m
+! diagnostic t,q a 2m et u, v a 10m
+
+       DO j=1, knon
+          i = ni(j)
+          uzon(j) = yu(j,1) + y_d_u(j,1)
+          vmer(j) = yv(j,1) + y_d_v(j,1)
+          tair1(j) = yt(j,1) + y_d_t(j,1)
+          qair1(j) = yq(j,1) + y_d_q(j,1)
+          zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
+               * (ypaprs(j,1)-ypplay(j,1))
+          tairsol(j) = yts(j) + y_d_ts(j)
+          rugo1(j) = yrugos(j)
+          IF(nsrf.EQ.is_oce) THEN
+             rugo1(j) = rugos(i,nsrf)
+          ENDIF
+          psfce(j)=ypaprs(j,1)
+          patm(j)=ypplay(j,1)
+          qairsol(j) = yqsurf(j)
+       END DO
+       
+
+! Calculate the temperature et relative humidity at 2m and the wind at 10m 
+       CALL stdlevvar(klon, knon, nsrf, zxli, &
+            uzon, vmer, tair1, qair1, zgeo1, &
+            tairsol, qairsol, rugo1, psfce, patm, &
+            yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
+
+       DO j=1, knon
+          i = ni(j)
+          t2m(i,nsrf)=yt2m(j)
+          
+          q2m(i,nsrf)=yq2m(j)
+
+! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
+          u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2)
+          v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2)
+
+       END DO
+
+
+       CALL HBTM(knon, ypaprs, ypplay, &
+            yt2m,yt10m,yq2m,yq10m,yustar, &
+            y_flux_t,y_flux_q,yu,yv,yt,yq, &
+            ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, &
+            ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl)
+       
+       DO j=1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = ypblh(j)
+          plcl(i,nsrf)   = ylcl(j)
+          capCL(i,nsrf)  = ycapCL(j)
+          oliqCL(i,nsrf) = yoliqCL(j)
+          cteiCL(i,nsrf) = ycteiCL(j)
+          pblT(i,nsrf)   = ypblT(j)
+          therm(i,nsrf)  = ytherm(j)
+          trmb1(i,nsrf)  = ytrmb1(j)
+          trmb2(i,nsrf)  = ytrmb2(j)
+          trmb3(i,nsrf)  = ytrmb3(j)
+       END DO
+       
+#else 
+! not defined T2m
+! No calculation
+! Set output variables to zero
+       DO j = 1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = 0.
+          plcl(i,nsrf)   = 0.
+          capCL(i,nsrf)  = 0.
+          oliqCL(i,nsrf) = 0.
+          cteiCL(i,nsrf) = 0.
+          pblT(i,nsrf)   = 0.
+          therm(i,nsrf)  = 0.
+          trmb1(i,nsrf)  = 0.
+          trmb2(i,nsrf)  = 0.
+          trmb3(i,nsrf)  = 0.
+       END DO
+       DO j = 1, knon
+          i = ni(j) 
+          t2m(i,nsrf)=0.
+          q2m(i,nsrf)=0.
+          u10m(i,nsrf)=0.
+          v10m(i,nsrf)=0.
+       END DO
+#endif
+
+!****************************************************************************************
+! 15) End of loop over different surfaces
+!
+!****************************************************************************************
+    END DO loop_nbsrf
+
+!****************************************************************************************
+! 16) Calculate the mean value over all sub-surfaces for som variables
+!
+!     NB!!! jg : Pour garder la convergence numerique j'utilise pctsrf_new comme c'etait 
+!     fait dans physiq.F mais ca devrait plutot etre pctsrf???!!!!! A verifier!
+!****************************************************************************************
+    
+    zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
+    zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO k = 1, klev
+          DO i = 1, klon
+             zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf_new(i,nsrf)
+          END DO
+       END DO
+    END DO
+
+    DO i = 1, klon
+       zxsens(i)     = - zxfluxt(i,1) ! flux de chaleur sensible au sol
+       zxevap(i)     = - zxfluxq(i,1) ! flux d'evaporation au sol
+       fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i)
+    ENDDO
+   
+
+    DO i = 1, klon
+       IF ( ABS( pctsrf_new(i, is_ter) + pctsrf_new(i, is_lic) + &
+            pctsrf_new(i, is_oce) + pctsrf_new(i, is_sic)  - 1.) .GT. EPSFRA) & 
+            THEN 
+          WRITE(*,*) 'physiq : pb sous surface au point ', i, &
+               pctsrf_new(i, 1 : nbsrf)
+       ENDIF
+    ENDDO
+
+!
+! Incrementer la temperature du sol
+!
+    zxtsol(:) = 0.0  ; zxfluxlat(:) = 0.0
+    zt2m(:) = 0.0    ; zq2m(:) = 0.0 
+    zu10m(:) = 0.0   ; zv10m(:) = 0.0
+    s_pblh(:) = 0.0  ; s_plcl(:) = 0.0 
+    s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0
+    s_cteiCL(:) = 0.0; s_pblT(:) = 0.0
+    s_therm(:) = 0.0 ; s_trmb1(:) = 0.0
+    s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0
+    
+    
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon          
+          ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf)
+          
+          wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) &
+               + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf_new(i,nsrf)
+          wfbilo(i,nsrf) = (evap(i,nsrf) - (rain_f(i) + snow_f(i))) * &
+               pctsrf_new(i,nsrf)
+
+          zxtsol(i)    = zxtsol(i)    + ts(i,nsrf)      * pctsrf_new(i,nsrf)
+          zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf_new(i,nsrf)
+          
+          zt2m(i)  = zt2m(i)  + t2m(i,nsrf)  * pctsrf_new(i,nsrf)
+          zq2m(i)  = zq2m(i)  + q2m(i,nsrf)  * pctsrf_new(i,nsrf)
+          zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf_new(i,nsrf)
+          zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf_new(i,nsrf)
+
+          s_pblh(i)   = s_pblh(i)   + pblh(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_plcl(i)   = s_plcl(i)   + plcl(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_capCL(i)  = s_capCL(i)  + capCL(i,nsrf) * pctsrf_new(i,nsrf)
+          s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf_new(i,nsrf)
+          s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf_new(i,nsrf)
+          s_pblT(i)   = s_pblT(i)   + pblT(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_therm(i)  = s_therm(i)  + therm(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb1(i)  = s_trmb1(i)  + trmb1(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb2(i)  = s_trmb2(i)  + trmb2(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb3(i)  = s_trmb3(i)  + trmb3(i,nsrf) * pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+    IF (check) THEN
+       amn=MIN(ts(1,is_ter),1000.)
+       amx=MAX(ts(1,is_ter),-1000.)
+       DO i=2, klon
+          amn=MIN(ts(i,is_ter),amn)
+          amx=MAX(ts(i,is_ter),amx)
+       ENDDO
+       PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx
+    ENDIF
+!
+! If a sub-surface does not exsist for a grid point, the mean value for all 
+! sub-surfaces is distributed.
+!
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN
+             ts(i,nsrf)     = zxtsol(i)
+             t2m(i,nsrf)    = zt2m(i)
+             q2m(i,nsrf)    = zq2m(i)
+             u10m(i,nsrf)   = zu10m(i)
+             v10m(i,nsrf)   = zv10m(i)
+
+! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour
+             pblh(i,nsrf)   = s_pblh(i)
+             plcl(i,nsrf)   = s_plcl(i)
+             capCL(i,nsrf)  = s_capCL(i)
+             oliqCL(i,nsrf) = s_oliqCL(i) 
+             cteiCL(i,nsrf) = s_cteiCL(i)
+             pblT(i,nsrf)   = s_pblT(i)
+             therm(i,nsrf)  = s_therm(i)
+             trmb1(i,nsrf)  = s_trmb1(i)
+             trmb2(i,nsrf)  = s_trmb2(i)
+             trmb3(i,nsrf)  = s_trmb3(i)
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+    DO i = 1, klon
+       fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 
+    ENDDO
+    
+    zxqsurf(:) = 0.0
+    zxsnow(:)  = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf_new(i,nsrf)
+          zxsnow(i)  = zxsnow(i)  + snow(i,nsrf)  * pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+!
+!IM Calculer l'humidite relative a 2m (rh2m) pour diagnostique
+!IM ajout dependance type surface
+    rh2m(:)   = 0.0
+    qsat2m(:) = 0.0
+
+    DO i = 1, klon
+       DO nsrf=1, nbsrf
+          zx_t1(i,nsrf) = t2m(i,nsrf)
+          IF (thermcep) THEN
+             zdelta1(i,nsrf) = MAX(0.,SIGN(1.,rtt-zx_t1(i,nsrf)))
+             zx_qs1(i,nsrf)  = r2es * &
+                  FOEEW(zx_t1(i,nsrf),zdelta1(i,nsrf))/paprs(i,1)
+             zx_qs1(i,nsrf)  = MIN(0.5,zx_qs1(i,nsrf))
+             zcor1(i,nsrf)   = 1./(1.-retv*zx_qs1(i,nsrf))
+             zx_qs1(i,nsrf)  = zx_qs1(i,nsrf)*zcor1(i,nsrf)
+          END IF
+          zx_rh2m(i,nsrf) = q2m(i,nsrf)/zx_qs1(i,nsrf)
+          zx_qsat2m(i,nsrf)=zx_qs1(i,nsrf)
+          rh2m(i) = rh2m(i)+zx_rh2m(i,nsrf)*pctsrf_new(i,nsrf)
+          qsat2m(i)=qsat2m(i)+zx_qsat2m(i,nsrf)*pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+! 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
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, &
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! 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
+
+ 
+!****************************************************************************************
+! Return module variables for writing to restart file
+!
+!****************************************************************************************    
+    qsol_rst(:)       = qsol(:)
+    fder_rst(:)       = fder(:)
+    snow_rst(:,:)     = snow(:,:)
+    qsurf_rst(:,:)    = qsurf(:,:)
+    evap_rst(:,:)     = evap(:,:)
+    rugos_rst(:,:)    = rugos(:,:)
+    agesno_rst(:,:)   = agesno(:,:)
+    ftsoil_rst(:,:,:) = ftsoil(:,:,:)
+
+!****************************************************************************************
+! Deallocate module variables
+!
+!****************************************************************************************
+    DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
+
+  END SUBROUTINE pbl_surface_final
+!  
+!****************************************************************************************
+!  
+
+END MODULE pbl_surface_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phyetat0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phyetat0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phyetat0.F	(revision 984)
@@ -0,0 +1,1573 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm_etat0,solaire_etat0,
+     .           rlat_p, rlon_p, pctsrf_p, tsol_p,
+     .           ocean_in, ok_veget_in,
+     .           alb1_p, alb2_p,
+     .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,
+     .           radsol_p,clesphy0,
+     .           zmea_p,zstd_p,zsig_p,zgam_p,zthe_p,zpic_p,zval_p,
+     .           rugsrel_p,tabcntr0,
+     .           t_ancien_p,q_ancien_p,ancien_ok_p, rnebcon_p, ratqs_p,
+     .           clwcon_p)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE ocean_slab_mod,   ONLY : ocean_slab_init
+      USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+      USE ocean_forced_mod, ONLY : ocean_forced_init
+      USE fonte_neige_mod,  ONLY : fonte_neige_init
+      USE pbl_surface_mod,  ONLY : pbl_surface_init
+      USE surface_data,     ONLY : ocean, ok_veget
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Lecture de l'etat initial pour la physique
+c======================================================================
+#include "dimensions.h"
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
+      INTEGER radpas
+      REAL rlat_p(klon), rlon_p(klon)
+      REAL co2_ppm_etat0
+      REAL solaire_etat0
+      REAL tsol_p(klon,nbsrf)
+      REAL tsoil_p(klon,nsoilmx,nbsrf)
+      REAL tslab_p(klon), seaice_p(klon)
+      REAL qsurf_p(klon,nbsrf)
+      REAL qsol_p(klon)
+      REAL snow_p(klon,nbsrf)
+      REAL alb1_p(klon,nbsrf)   ! albedo in visible SW interval
+      REAL alb2_p(klon,nbsrf)   ! albedo in near IR interval
+      REAL evap_p(klon,nbsrf)
+      REAL radsol_p(klon)
+      REAL rain_fall_p(klon)
+      REAL snow_fall_p(klon)
+      REAL sollw_p(klon)
+      real solsw_p(klon)
+      real fder_p(klon)
+      REAL frugs_p(klon,nbsrf)
+      REAL agesno_p(klon,nbsrf)
+      REAL zmea_p(klon)
+      REAL zstd_p(klon)
+      REAL zsig_p(klon)
+      REAL zgam_p(klon)
+      REAL zthe_p(klon)
+      REAL zpic_p(klon)
+      REAL zval_p(klon)
+      REAL rugsrel_p(klon)
+      REAL pctsrf_p(klon, nbsrf)
+      REAL run_off_lic_0_p(klon)
+      
+      REAL t_ancien_p(klon,klev), q_ancien_p(klon,klev)
+      real rnebcon_p(klon,klev),clwcon_p(klon,klev)
+      real ratqs_p(klon,klev)
+      LOGICAL,SAVE ::  ancien_ok
+      LOGICAL ::  ancien_ok_p
+      
+      REAL zmasq_glo(klon_glo)
+      REAL rlat(klon_glo), rlon(klon_glo)
+      REAL tsol(klon_glo,nbsrf)
+      REAL tsoil(klon_glo,nsoilmx,nbsrf)
+cIM "slab" ocean
+      REAL tslab(klon_glo), seaice(klon_glo)
+      REAL qsurf(klon_glo,nbsrf)
+      REAL qsol(klon_glo)
+      REAL snow(klon_glo,nbsrf)
+      REAL alb1(klon_glo,nbsrf)
+      REAL alb2(klon_glo,nbsrf)
+      REAL evap(klon_glo,nbsrf)
+      REAL radsol(klon_glo)
+      REAL rain_fall(klon_glo)
+      REAL snow_fall(klon_glo)
+      REAL sollw(klon_glo)
+      real solsw(klon_glo)
+      real fder(klon_glo)
+      REAL frugs(klon_glo,nbsrf)
+      REAL agesno(klon_glo,nbsrf)
+      REAL zmea(klon_glo)
+      REAL zstd(klon_glo)
+      REAL zsig(klon_glo)
+      REAL zgam(klon_glo)
+      REAL zthe(klon_glo)
+      REAL zpic(klon_glo)
+      REAL zval(klon_glo)
+      REAL rugsrel(klon_glo)
+      REAL pctsrf(klon_glo, nbsrf)
+      REAL fractint(klon_glo)
+      REAL run_off_lic_0(klon_glo)
+      REAL t_ancien(klon_glo,klev)
+      REAL q_ancien(klon_glo,klev)
+      real rnebcon(klon_glo,klev)
+      real clwcon(klon_glo,klev)
+      real ratqs(klon_glo,klev)
+
+      CHARACTER*6 ocean_in
+      LOGICAL ok_veget_in
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+c
+      REAL xmin, xmax
+c
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil ,k
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length), tabcntr0(length)
+      REAL,SAVE :: tab_cntrl_omp(length)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+
+c FH1D
+c     real iolat(jjm+1)
+      real iolat(jjm+1-1/iim)
+c
+c Ouvrir le fichier contenant l'etat initial:
+c
+
+c$OMP MASTER
+      print *,'MASTER -x , omp_rank=',omp_rank
+c$OMP END MASTER
+
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+        print*,'fichnom ',fichnom
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Pb d''ouverture du fichier '//fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+      ENDIF
+c$OMP END MASTER
+c
+c Lecture des parametres de controle:
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <controle> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <controle>'
+         CALL abort
+      ENDIF
+      ENDIF
+
+c$OMP END MASTER
+       
+       CALL bcast(tab_cntrl)
+       
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Les constantes de la physiques sont lues dans la physique seulement.
+! Les egalites du type
+!             tab_cntrl( 5 )=clesphy0(1)
+! sont remplacees par
+!             clesphy0(1)=tab_cntrl( 5 )
+! On inverse aussi la logique.
+! On remplit les tab_cntrl avec les parametres lus dans les .def
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         DO i = 1, length
+           tabcntr0( i ) = tab_cntrl( i )
+         ENDDO
+c
+         tab_cntrl(1)=dtime
+         tab_cntrl(2)=radpas
+         co2_ppm_etat0      = tab_cntrl(3)
+         solaire_etat0      = tab_cntrl(4)
+         tab_cntrl(5)=iflag_con
+         tab_cntrl(6)=nbapp_rad
+
+         if (cycle_diurne) tab_cntrl( 7) =1.
+         if (soil_model) tab_cntrl( 8) =1.
+         if (new_oliq) tab_cntrl( 9) =1.
+         if (ok_orodr) tab_cntrl(10) =1.
+         if (ok_orolf) tab_cntrl(11) =1.
+         if (ok_limitvrai) tab_cntrl(12) =1.
+
+
+      itau_phy = tab_cntrl(15)
+
+       
+
+         IF( clesphy0(1).NE.tab_cntrl( 5 ) )  THEN
+             clesphy0(1)=tab_cntrl( 5 )
+         ENDIF
+
+         IF( clesphy0(2).NE.tab_cntrl( 6 ) )  THEN
+             clesphy0(2)=tab_cntrl( 6 )
+         ENDIF
+
+         IF( clesphy0(3).NE.tab_cntrl( 7 ) )  THEN
+             clesphy0(3)=tab_cntrl( 7 )
+         ENDIF
+
+         IF( clesphy0(4).NE.tab_cntrl( 8 ) )  THEN
+             clesphy0(4)=tab_cntrl( 8 )
+         ENDIF
+
+         IF( clesphy0(5).NE.tab_cntrl( 9 ) )  THEN
+             clesphy0(5)=tab_cntrl( 9 )
+         ENDIF
+
+         IF( clesphy0(6).NE.tab_cntrl( 10 ) )  THEN
+             clesphy0(6)=tab_cntrl( 10 )
+         ENDIF
+
+         IF( clesphy0(7).NE.tab_cntrl( 11 ) )  THEN
+             clesphy0(7)=tab_cntrl( 11 )
+         ENDIF
+
+         IF( clesphy0(8).NE.tab_cntrl( 12 ) )  THEN
+             clesphy0(8)=tab_cntrl( 12 )
+         ENDIF
+
+
+c
+c Lecture des latitudes (coordonnees):
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <latitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlat)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <longitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlon)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+C
+C
+C Lecture du masque terre mer
+C
+
+      ierr = NF_INQ_VARID (nid, "masque", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmasq_glo)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, zmasq_glo)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <masque>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <masque> est absent'
+          PRINT*, 'fichier startphy non compatible avec phyetat0'
+C      CALL abort
+      ENDIF
+
+       
+C Lecture des fractions pour chaque sous-surface
+C
+C initialisation des sous-surfaces
+C
+      pctsrf = 0.
+C
+C fraction de terre
+C
+
+      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid,        
+     .                             pctsrf(1 : klon_glo,is_ter))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo,is_ter))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FTER>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FTER> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C fraction de glace de terre
+C
+      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf(1 : klon_glo,is_lic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo,is_lic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FLIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+c@$$         CALL abort
+      ENDIF
+C
+C fraction d'ocean
+C
+      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf(1 : klon_glo,is_oce))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo,is_oce))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FOCE>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C fraction glace de mer
+C
+      ierr = NF_INQ_VARID (nid, "FSIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf(1 : klon_glo,is_sic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo, is_sic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FSIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C  Verification de l'adequation entre le masque et les sous-surfaces
+C
+      fractint( 1 : klon_glo) = pctsrf(1 : klon_glo, is_ter) 
+     $    + pctsrf(1 : klon_glo, is_lic)
+      DO i = 1 , klon_glo
+        IF ( abs(fractint(i) - zmasq_glo(i) ) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0: attention fraction terre pas ', 
+     $          'coherente ', i, zmasq_glo(i), pctsrf(i, is_ter)
+     $          ,pctsrf(i, is_lic)
+        ENDIF 
+      END DO 
+      fractint (1 : klon_glo) =  pctsrf(1 : klon_glo, is_oce) 
+     $    + pctsrf(1 : klon_glo, is_sic)
+      DO i = 1 , klon_glo
+        IF ( abs( fractint(i) - (1. - zmasq_glo(i))) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0 attention fraction ocean pas ', 
+     $          'coherente ', i, zmasq_glo(i) , pctsrf(i, is_oce)
+     $          ,pctsrf(i, is_sic)
+        ENDIF 
+      END DO 
+
+C
+c Lecture des temperatures du sol:
+c
+
+      ierr = NF_INQ_VARID (nid, "TS", nvarid)
+      IF (ierr.NE.NF_NOERR) 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"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "TS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <TS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <TS"//str2//">"
+             CALL abort
+           ENDIF
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              xmin = MIN(tsol(i,nsrf),xmin)
+              xmax = MAX(tsol(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <TS> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(tsol(i,1),xmin)
+            xmax = MAX(tsol(i,1),xmax)
+         ENDDO
+         PRINT*,'Temperature du sol <TS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            tsol(i,nsrf) = tsol(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture des temperatures du sol profond:
+c
+      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
+      ENDIF
+      WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+      ierr = NF_INQ_VARID (nid, 'Tsoil'//str7, nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+         PRINT*, "          Il prend donc la valeur de surface"
+         DO i=1, klon_glo
+             tsoil(i,isoil,nsrf)=tsol(i,nsrf)
+         ENDDO
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil,nsrf))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil,nsrf))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "Lecture echouee pour <Tsoil"//str7//">"
+            CALL abort
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cIM "slab" ocean 
+c
+c Lecture de tslab (pour slab ocean seulement):      
+c
+      IF (ocean_in .eq. 'slab  ') then
+        ierr = NF_INQ_VARID (nid, "TSLAB", nvarid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Le champ <TSLAB> est absent"
+          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tslab)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, tslab)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Lecture echouee pour <TSLAB>"
+          CALL abort
+        ENDIF
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO i = 1, klon_glo
+          xmin = MIN(tslab(i),xmin)
+          xmax = MAX(tslab(i),xmax)
+        ENDDO
+        PRINT*,'Min, Max tslab (utilise si OCEAN=slab )', xmin, xmax
+c
+c Lecture de seaice (pour slab ocean seulement):
+c
+        ierr = NF_INQ_VARID (nid, "SEAICE", nvarid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Le champ <SEAICE> est absent"
+          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, seaice)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, seaice)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Lecture echouee pour <SEAICE>"
+          CALL abort
+        ENDIF
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO i = 1, klon_glo
+          xmin = MIN(seaice(i),xmin)
+          xmax = MAX(seaice(i),xmax)
+        ENDDO
+        PRINT*,'Masse de la glace de mer (utilise si OCEAN=slab)', 
+     $  xmin, xmax
+      ELSE
+        tslab = 0.
+        seaice = 0.
+      ENDIF
+c
+c Lecture de l'humidite de l'air juste au dessus du sol:
+c
+      ierr = NF_INQ_VARID (nid, "QS", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "QS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <QS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <QS"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            qsurf(i,nsrf) = qsurf(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+C
+C Eau dans le sol (pour le modele de sol "bucket")
+C
+      ierr = NF_INQ_VARID (nid, "QSOL", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, qsol)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <QSOL>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <QSOL> est absent'
+          PRINT*, '          Valeur par defaut nulle'
+          qsol(:)=0.
+c@$$         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+        xmin = MIN(qsol(i),xmin)
+        xmax = MAX(qsol(i),xmax)
+      ENDDO
+      PRINT*,'Eau dans le sol (mm) <QSOL>', xmin, xmax
+c
+c Lecture de neige au sol:
+c
+      ierr = NF_INQ_VARID (nid, "SNOW", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "SNOW"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <SNOW"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <SNOW"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <SNOW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            snow(i,nsrf) = snow(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de albedo de l'interval visible au sol:
+c
+      ierr = NF_INQ_VARID (nid, "ALBE", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "ALBE"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <ALBE"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb1(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, alb1(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <ALBE"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              xmin = MIN(alb1(i,nsrf),xmin)
+              xmax = MAX(alb1(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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb1(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, alb1(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBE>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(alb1(i,1),xmin)
+            xmax = MAX(alb1(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBE>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            alb1(i,nsrf) = alb1(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de albedo au sol dans l'interval proche infra-rouge:
+c
+      ierr = NF_INQ_VARID (nid, "ALBLW", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
+c        PRINT*, '          Mais je vais essayer de lire ALBLW**'
+         PRINT*, '          Mais je vais prendre ALBE**'
+         DO nsrf = 1, nbsrf
+           DO i = 1, klon_glo
+             alb2(i,nsrf) = alb1(i,nsrf)
+           ENDDO
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBLW> est present'
+         PRINT*, '          J ignore donc les autres ALBLW**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb2(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, alb2(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBLW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(alb2(i,1),xmin)
+            xmax = MAX(alb2(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBLW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            alb2(i,nsrf) = alb2(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de evaporation:  
+c
+      ierr = NF_INQ_VARID (nid, "EVAP", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "EVAP"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <EVAP"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <EVAP"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <EVAP>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            evap(i,nsrf) = evap(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture precipitation liquide:
+c
+      ierr = NF_INQ_VARID (nid, "rain_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <rain_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rain_fall)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rain_fall)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <rain_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(rain_fall(i),xmin)
+         xmax = MAX(rain_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation liquide rain_f:', xmin, xmax
+c
+c Lecture precipitation solide:
+c
+      ierr = NF_INQ_VARID (nid, "snow_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <snow_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow_fall)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, snow_fall)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <snow_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(snow_fall(i),xmin)
+         xmax = MAX(snow_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation solide snow_f:', xmin, xmax
+c
+c Lecture rayonnement solaire au sol:
+c
+      ierr = NF_INQ_VARID (nid, "solsw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <solsw> est absent'
+         PRINT*, 'mis a zero'
+         solsw = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, solsw)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <solsw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(solsw(i),xmin)
+         xmax = MAX(solsw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
+c
+c Lecture rayonnement IF au sol:
+c
+      ierr = NF_INQ_VARID (nid, "sollw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <sollw> est absent'
+         PRINT*, 'mis a zero'
+         sollw = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, sollw)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <sollw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(sollw(i),xmin)
+         xmax = MAX(sollw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
+      
+      ENDIF  ! is_mpi_root
+c$OMP END MASTER
+
+
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+c
+c Lecture derive des flux:
+c
+      ierr = NF_INQ_VARID (nid, "fder", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <fder> est absent'
+         PRINT*, 'mis a zero'
+         fder = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, fder)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <fder>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(fder(i),xmin)
+         xmax = MAX(fder(i),xmax)
+      ENDDO
+      PRINT*,'Derive des flux fder:', xmin, xmax
+
+c
+c Lecture du rayonnement net au sol:
+c
+      ierr = NF_INQ_VARID (nid, "RADS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RADS> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, radsol)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RADS>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(radsol(i),xmin)
+         xmax = MAX(radsol(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
+c
+c Lecture de la longueur de rugosite 
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUG", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "RUG"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <RUG"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <RUG"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUG>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            frugs(i,nsrf) = frugs(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de l'age de la neige:
+c
+      ierr = NF_INQ_VARID (nid, "AGESNO", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "AGESNO"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
+              agesno = 50.0
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <AGESNO"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <AGESNO>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            agesno(i,nsrf) = agesno(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "ZMEA", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZMEA> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zmea)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZMEA>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSTD", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSTD> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zstd)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSTD>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSIG", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSIG> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zsig)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSIG>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZGAM", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZGAM> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zgam)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZGAM>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZTHE", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZTHE> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zthe)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZTHE>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZPIC", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZPIC> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zpic)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZPIC>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zpic(i),xmin)
+         xmax = MAX(zpic(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
+c
+      ierr = NF_INQ_VARID (nid, "ZVAL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZVAL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zval)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZVAL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zval(i),xmin)
+         xmax = MAX(zval(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUGSREL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RUGSREL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugsrel)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rugsrel)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RUGSREL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(rugsrel(i),xmin)
+         xmax = MAX(rugsrel(i),xmax)
+      ENDDO
+      PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
+c
+c
+      ancien_ok = .TRUE.
+c
+      ierr = NF_INQ_VARID (nid, "TANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, t_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, t_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      clwcon=0.
+      ierr = NF_INQ_VARID (nid, "CLWCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ CLWCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         clwcon = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, clwcon)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, clwcon)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <CLWCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon)
+      xmax = MAXval(clwcon)
+      PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
+c
+      rnebcon=0.
+      ierr = NF_INQ_VARID (nid, "RNEBCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ RNEBCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         rnebcon = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rnebcon)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, rnebcon)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RNEBCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon)
+      xmax = MAXval(rnebcon)
+      PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
+
+c
+c Lecture ratqs
+c
+       ratqs=0.
+      ierr = NF_INQ_VARID (nid, "RATQS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RATQS> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ratqs = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ratqs)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, ratqs)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RATQS>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs)
+      xmax = MAXval(ratqs)
+      PRINT*,'(ecart-type) ratqs:', xmin, xmax
+c
+c Lecture run_off_lic_0
+c
+      ierr = NF_INQ_VARID (nid, "RUNOFFLIC0", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         run_off_lic_0 = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, run_off_lic_0)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, run_off_lic_0)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUNOFFLIC0>"
+            CALL abort
+         ENDIF
+      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
+
+
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+      ENDIF ! is_mpi_root
+c
+c$OMP END MASTER
+
+c$OMP MASTER
+cym  en attendant mieux
+        iolat(1)=rlat(1)
+
+!FH1D   
+!iolat(jjm+1)=rlat(klon_glo)
+	iolat(jjm+1-1/iim)=rlat(klon_glo)
+        if (iim.gt.1) then
+	do i=2,jjm
+	  iolat(i)=rlat(2+(i-2)*iim)
+	enddo
+        endif
+
+	CALL bcast_mpi(iolat)
+	CALL bcast_mpi(rlon)
+
+!FH1D
+!       call init_iophy(iolat,rlon(2:iim+1))
+        call init_iophy(iolat,rlon(2-1/iim:iim+1-1/iim))
+       
+c$OMP END MASTER
+      	
+      call Scatter( rlat,rlat_p)
+      call Scatter( rlon,rlon_p)
+      call Scatter( tsol,tsol_p)
+      call Scatter( tsoil,tsoil_p)
+      call Scatter( tslab,tslab_p)
+      call Scatter( seaice,seaice_p)
+      call Scatter( qsurf,qsurf_p)
+      call Scatter( qsol,qsol_p)
+      call Scatter( snow,snow_p)
+      call Scatter( alb1,alb1_p)
+      call Scatter( alb2,alb2_p)
+      call Scatter( evap,evap_p)
+      call Scatter( radsol,radsol_p)
+      call Scatter( rain_fall,rain_fall_p)
+      call Scatter( snow_fall,snow_fall_p)
+      call Scatter( sollw,sollw_p)
+      call Scatter( solsw,solsw_p)
+      call Scatter( fder,fder_p)
+      call Scatter( frugs,frugs_p)
+      call Scatter( agesno,agesno_p)
+      call Scatter( zmea,zmea_p)
+      call Scatter( zstd,zstd_p)
+      call Scatter( zsig,zsig_p)
+      call Scatter( zgam,zgam_p)
+      call Scatter( zthe,zthe_p)
+      call Scatter( zpic,zpic_p)
+      call Scatter( zval,zval_p)
+      call Scatter( rugsrel,rugsrel_p)
+      call Scatter( pctsrf,pctsrf_p)
+      call Scatter( run_off_lic_0,run_off_lic_0_p)
+      call Scatter( t_ancien,t_ancien_p)
+      call Scatter( q_ancien,q_ancien_p)
+      call Scatter( rnebcon,rnebcon_p)
+      call Scatter( clwcon,clwcon_p)
+      call Scatter( ratqs,ratqs_p)
+      call Scatter( zmasq_glo,zmasq)
+
+c
+c Initilalize variables in module surface_data
+c
+      ok_veget = ok_veget_in
+      ocean    = ocean_in
+c
+c Initialize module pbl_surface_mod 
+c
+      CALL pbl_surface_init(qsol_p, fder_p, snow_p, qsurf_p,
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Initialize ocean module according to ocean type
+      IF ( ocean == 'slab' ) THEN
+c        initilalize module ocean_slab_init
+         CALL ocean_slab_init(dtime, tslab_p, seaice_p, pctsrf_p)
+      ELSEIF ( ocean == 'couple' ) THEN
+c        initilalize module ocean_cpl_init
+         CALL ocean_cpl_init(dtime, rlon_p, rlat_p)
+      ELSE
+c        initilalize module ocean_forced_init
+         CALL ocean_forced_init
+      ENDIF
+c
+c Initilialize module fonte_neige_mod      
+c
+      CALL fonte_neige_init(run_off_lic_0_p)
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phyredem.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phyredem.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phyredem.F	(revision 984)
@@ -0,0 +1,906 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE phyredem (fichnom,dtime,radpas,ocean,
+     .           rlat_p,rlon_p, pctsrf_p,tsol_p,
+     .           albedo_p, alblw_p,
+     .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,
+     .           radsol_p,zmea_p,zstd_p,zsig_p,
+     .           zgam_p,zthe_p,zpic_p,zval_p,rugsrel_p,
+     .           t_ancien_p, q_ancien_p, rnebcon_p, ratqs_p, clwcon_p)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE ocean_slab_mod,   ONLY : ocean_slab_final
+      USE fonte_neige_mod,  ONLY : fonte_neige_final
+      USE pbl_surface_mod,  ONLY : pbl_surface_final
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ecriture de l'etat de redemarrage pour la physique
+c======================================================================
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "temps.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
+      INTEGER radpas
+      REAL rlat_p(klon), rlon_p(klon)
+      REAL tsol_p(klon,nbsrf)
+      REAL tsoil_p(klon,nsoilmx,nbsrf)
+      CHARACTER*6 ocean
+cIM "slab" ocean
+      REAL tslab_p(klon), seaice_p(klon)
+      REAL qsurf_p(klon,nbsrf)
+      REAL qsol_p(klon)
+      REAL snow_p(klon,nbsrf)
+      REAL albedo_p(klon,nbsrf)
+cIM BEG
+      REAL alblw_p(klon,nbsrf)
+cIM END
+      REAL evap_p(klon,nbsrf)
+      REAL rain_fall_p(klon)
+      REAL snow_fall_p(klon)
+      real solsw_p(klon)
+      real sollw_p(klon)
+      real fder_p(klon)
+      REAL radsol_p(klon)
+      REAL frugs_p(klon,nbsrf)
+      REAL agesno_p(klon,nbsrf)
+      REAL zmea_p(klon)
+      REAL zstd_p(klon)
+      REAL zsig_p(klon)
+      REAL zgam_p(klon)
+      REAL zthe_p(klon)
+      REAL zpic_p(klon)
+      REAL zval_p(klon)
+      REAL rugsrel_p(klon)
+      REAL pctsrf_p(klon, nbsrf)
+      REAL t_ancien_p(klon,klev), q_ancien_p(klon,klev)
+      real clwcon_p(klon,klev),rnebcon_p(klon,klev),ratqs_p(klon,klev)
+      REAL run_off_lic_0_p(klon)
+      
+      REAL rlat(klon_glo), rlon(klon_glo)
+      REAL tsol(klon_glo,nbsrf)
+      REAL tsoil(klon_glo,nsoilmx,nbsrf)
+      REAL tslab(klon_glo), seaice(klon_glo)
+      REAL qsurf(klon_glo,nbsrf)
+      REAL qsol(klon_glo)
+      REAL snow(klon_glo,nbsrf)
+      REAL albedo(klon_glo,nbsrf)
+      REAL alblw(klon_glo,nbsrf)
+      REAL evap(klon_glo,nbsrf)
+      REAL rain_fall(klon_glo)
+      REAL snow_fall(klon_glo)
+      real solsw(klon_glo)
+      real sollw(klon_glo)
+      real fder(klon_glo)
+      REAL radsol(klon_glo)
+      REAL frugs(klon_glo,nbsrf)
+      REAL agesno(klon_glo,nbsrf)
+      REAL zmea(klon_glo)
+      REAL zstd(klon_glo)
+      REAL zsig(klon_glo)
+      REAL zgam(klon_glo)
+      REAL zthe(klon_glo)
+      REAL zpic(klon_glo)
+      REAL zval(klon_glo)
+      REAL rugsrel(klon_glo)
+      REAL pctsrf(klon_glo, nbsrf)
+      REAL t_ancien(klon_glo,klev), q_ancien(klon_glo,klev)
+      REAL clwcon(klon_glo,klev)
+      REAL rnebcon(klon_glo,klev) 
+      REAL ratqs(klon_glo,klev)
+      REAL run_off_lic_0(klon_glo)
+      REAL masq(klon_glo)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+c
+      INTEGER isoil, nsrf
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+
+c======================================================================
+c 
+c Get variables which will be written to restart file from module 
+c pbl_surface_mod
+      CALL pbl_surface_final(qsol_p, fder_p, snow_p, qsurf_p, 
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Get a variable calculated in module fonte_neige_mod
+      CALL fonte_neige_final(run_off_lic_0_p)
+
+c If slab ocean then get 2 varaibles from module ocean_slab_mod
+      IF ( ocean == 'slab' ) THEN
+         CALL ocean_slab_final(tslab_p, seaice_p)
+      ELSE 
+         tslab_p(:)  = 0.0
+         seaice_p(:) = 0.0
+      ENDIF      
+
+c======================================================================
+
+      call Gather( rlat_p,rlat)
+      call Gather( rlon_p,rlon)
+      call Gather( tsol_p,tsol)
+      call Gather( tsoil_p,tsoil)
+      call Gather( tslab_p,tslab)
+      call Gather( seaice_p,seaice)
+      call Gather( qsurf_p,qsurf)
+      call Gather( qsol_p,qsol)
+      call Gather( snow_p,snow)
+      call Gather( albedo_p,albedo)
+      call Gather( alblw_p,alblw)
+      call Gather( evap_p,evap)
+      call Gather( radsol_p,radsol)
+      call Gather( rain_fall_p,rain_fall)
+      call Gather( snow_fall_p,snow_fall)
+      call Gather( sollw_p,sollw)
+      call Gather( solsw_p,solsw)
+      call Gather( fder_p,fder)
+      call Gather( frugs_p,frugs)
+      call Gather( agesno_p,agesno)
+      call Gather( zmea_p,zmea)
+      call Gather( zstd_p,zstd)
+      call Gather( zsig_p,zsig)
+      call Gather( zgam_p,zgam)
+      call Gather( zthe_p,zthe)
+      call Gather( zpic_p,zpic)
+      call Gather( zval_p,zval)
+      call Gather( rugsrel_p,rugsrel)
+      call Gather( pctsrf_p,pctsrf)
+      call Gather( run_off_lic_0_p,run_off_lic_0)
+      call Gather( t_ancien_p,t_ancien)
+      call Gather( q_ancien_p,q_ancien)
+      call Gather( rnebcon_p,rnebcon)
+      call Gather( clwcon_p,clwcon)
+      call Gather( ratqs_p,ratqs)
+      call Gather( zmasq,masq)
+      
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//fichnom
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
+     .                       "Fichier redemmarage physique")
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim1)
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, idim2)
+      ierr = NF_DEF_DIM (nid, "horizon_vertical", klon_glo*klev, idim3)
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      tab_cntrl(1) = dtime
+      tab_cntrl(2) = radpas
+      tab_cntrl(3) = co2_ppm
+      tab_cntrl(4) = solaire
+      tab_cntrl(5) = iflag_con
+      tab_cntrl(6) = nbapp_rad
+
+      IF( cycle_diurne ) tab_cntrl( 7 ) = 1.
+      IF(   soil_model ) tab_cntrl( 8 ) = 1.
+      IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+      IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+      IF(     ok_orolf ) tab_cntrl(11 ) = 1.
+
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = annee_ref
+      tab_cntrl(15) = itau_phy
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Longitudes de la grille physique")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31,
+     .                        "Latitudes de la grille physique")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat)
+#endif
+c
+C PB ajout du masque terre/mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "masque", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16,
+     .                        "masque terre mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masq)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masq)
+#endif      
+c BP ajout des fraction de chaque sous-surface
+C
+C 1. fraction de terre 
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "fraction de continent")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo, is_ter))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_ter))
+#endif
+C 
+C 2. Fraction de glace de terre
+C 
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24,
+     .                        "fraction glace de terre")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo,is_lic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_lic))
+#endif
+C
+C 3. fraction ocean
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "fraction ocean")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo, is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_oce))
+#endif
+C
+C 4. Fraction glace de mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                        "fraction glace mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo, is_sic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_sic))
+#endif
+C
+C
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Temperature de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol(1,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+      DO isoil=1, nsoilmx
+        IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+        WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29,
+     .                        "Temperature du sol No."//str7)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de couches"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf))
+#endif
+      ENDDO
+      ENDDO
+c
+cIM "slab" ocean
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TSLAB", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TSLAB", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Ecart de la SST (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tslab)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tslab)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "SEAICE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "SEAICE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Glace de mer kg/m2 (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,seaice)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,seaice)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
+     .                        "Humidite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsurf(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsurf(1,nsrf))
+#endif
+      END DO
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"QSOL",NF_DOUBLE,1,idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"QSOL",NF_FLOAT,1,idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .    "Eau dans le sol (mm)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo(1,nsrf))
+#endif
+      ENDDO
+
+cIM BEG albedo LW
+        DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo LW de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alblw(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,alblw(1,nsrf))
+#endif
+      ENDDO
+cIM END albedo LW
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Evaporation de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf))
+#endif
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Neige de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf))
+#endif
+      ENDDO
+
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Rayonnement net a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Rayonnement solaire a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27,
+     .                        "Rayonnement IF a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "Derive de flux")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,fder)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "precipitation liquide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                        "precipitation solide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall)
+#endif
+c
+       endif
+c$OMP END MASTER
+cc ----> necessaire pour eviter bug openMP sur SX6
+c$OMP MASTER
+      if (is_mpi_root) then
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "rugosite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_DOUBLE,1,idim2
+     $          ,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2
+     $          ,nvarid)
+#endif
+            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Age de la neige surface No."//str2)
+            ierr = NF_ENDDEF(nid)
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno(1,nsrf))
+#endif
+      ENDDO
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Longueur de rugosite sur mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce))
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Eau liquide convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,clwcon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,clwcon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Nebulosite convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rnebcon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rnebcon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Ratqs")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ratqs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ratqs)
+#endif
+c
+c run_off_lic_0
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_DOUBLE,1,idim2,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_FLOAT, 1,idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Runofflic0")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,run_off_lic_0)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,run_off_lic_0)
+#endif
+c
+c
+      ierr = NF_CLOSE(nid)
+c
+      endif   ! is_mpi_root
+c$OMP END MASTER
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/physiq.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/physiq.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/physiq.F	(revision 984)
@@ -0,0 +1,3383 @@
+!
+! $Header$
+!
+c
+c#define IO_DEBUG
+
+      SUBROUTINE physiq (nlon,nlev,nqmax,
+     .            debut,lafin,rjourvrai,gmtime,pdtphys,
+     .            paprs,pplay,pphi,pphis,presnivs,clesphy0,
+     .            u,v,t,qx,
+     .            omega,
+#ifdef INCA
+     .            flxmass_w,
+#endif
+     .            d_u, d_v, d_t, d_qx, d_ps
+     .            , dudyn
+     .            , PVteta)
+
+      USE ioipsl
+      USE comgeomphy
+      USE write_field_phy
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE misc_mod, mydebug=>debug
+      USE vampir
+      USE pbl_surface_mod, ONLY : pbl_surface
+
+
+      USE ocean_slab_mod, ONLY   : ocean_slab_get_vars
+      USE ocean_cpl_mod, ONLY    : ocean_cpl_get_vars
+      USE ocean_forced_mod, ONLY : ocean_forced_get_vars
+      USE fonte_neige_mod, ONLY  : fonte_neige_get_vars
+
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c   CLEFS CPP POUR LES IO
+c   =====================
+c#define histhf
+#define histday
+#define histmth
+c#define histins
+c#define histmthNMC
+c#define histISCCP
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c nlon----input-I-nombre de points horizontaux
+c nlev----input-I-nombre de couches verticales
+c nqmax---input-I-nombre de traceurs (y compris vapeur d'eau) = 1
+c debut---input-L-variable logique indiquant le premier passage
+c lafin---input-L-variable logique indiquant le dernier passage
+c rjour---input-R-numero du jour de l'experience
+c gmtime--input-R-temps universel dans la journee (0 a 86400 s)
+c pdtphys-input-R-pas d'integration pour la physique (seconde)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
+c pphis---input-R-geopotentiel du sol
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+c u-------input-R-vitesse dans la direction X (de O a E) en m/s
+c v-------input-R-vitesse Y (de S a N) en m/s
+c t-------input-R-temperature (K)
+c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
+c d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
+c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
+c omega---input-R-vitesse verticale en Pa/s
+c d_u-----output-R-tendance physique de "u" (m/s/s)
+c d_v-----output-R-tendance physique de "v" (m/s/s)
+c d_t-----output-R-tendance physique de "t" (K/s)
+c d_qx----output-R-tendance physique de "qx" (kg/kg/s)
+c d_ps----output-R-tendance physique de la pression au sol
+cIM
+c PVteta--output-R-vorticite potentielle a des thetas constantes
+c======================================================================
+#include "dimensions.h"
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
+      integer iip1
+      parameter (iip1=iim+1)
+
+#include "regdim.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "logic.h"
+#include "temps.h"
+cym#include "comgeomphy.h"
+#include "advtrac.h"
+#include "iniprint.h"
+#include "thermcell.h"
+c======================================================================
+      LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
+      PARAMETER (ok_cvl=.TRUE.)
+      LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
+      PARAMETER (ok_gust=.FALSE.)
+c======================================================================
+      LOGICAL check ! Verifier la conservation du modele en eau
+      PARAMETER (check=.FALSE.)
+      LOGICAL ok_stratus ! Ajouter artificiellement les stratus
+      PARAMETER (ok_stratus=.FALSE.)
+c======================================================================
+      logical rnpb
+#ifdef INCA
+      parameter(rnpb=.false.)
+#else
+      parameter(rnpb=.true.)
+#endif
+c      ocean = type de modele ocean a utiliser: force, slab, couple
+      character*6 ocean
+      SAVE ocean
+c$OMP THREADPRIVATE(ocean)
+
+cIM "slab" ocean
+      REAL tslab(klon)    !Temperature du slab-ocean
+      REAL seaice(klon)   !glace de mer (kg/m2) 
+      REAL fluxo(klon)    !flux turbulents ocean-glace de mer 
+      REAL fluxg(klon)    !flux turbulents ocean-atmosphere
+      REAL amn, amx
+c======================================================================
+c Clef controlant l'activation du cycle diurne:
+ccc      LOGICAL cycle_diurne
+ccc      PARAMETER (cycle_diurne=.FALSE.)
+c======================================================================
+c Modele thermique du sol, a activer pour le cycle diurne:
+ccc      LOGICAL soil_model
+ccc      PARAMETER (soil_model=.FALSE.)
+      logical ok_veget
+      save ok_veget
+c$OMP THREADPRIVATE(ok_veget)
+c     parameter (ok_veget = .true.)
+c      parameter (ok_veget = .false.)
+c======================================================================
+c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
+c le calcul du rayonnement est celle apres la precipitation des nuages.
+c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
+c la condensation et la precipitation. Cette cle augmente les impacts
+c radiatifs des nuages.
+ccc      LOGICAL new_oliq
+ccc      PARAMETER (new_oliq=.FALSE.)
+c======================================================================
+c Clefs controlant deux parametrisations de l'orographie:
+cc      LOGICAL ok_orodr
+ccc      PARAMETER (ok_orodr=.FALSE.)
+ccc      LOGICAL ok_orolf
+ccc      PARAMETER (ok_orolf=.FALSE.)
+c======================================================================
+      LOGICAL ok_journe ! sortir le fichier journalier
+      save ok_journe
+c$OMP THREADPRIVATE(ok_journe)
+c
+      LOGICAL ok_mensuel ! sortir le fichier mensuel
+      save ok_mensuel
+c$OMP THREADPRIVATE(ok_mensuel)
+c
+      LOGICAL ok_instan ! sortir le fichier instantane
+      save ok_instan
+c$OMP THREADPRIVATE(ok_instan)
+c
+      LOGICAL ok_region ! sortir le fichier regional
+      PARAMETER (ok_region=.FALSE.)
+c======================================================================
+c     pour phsystoke avec thermiques
+      REAL fm_therm(klon,klev+1)
+      REAL entr_therm(klon,klev)
+c======================================================================
+c
+      INTEGER ivap          ! indice de traceurs pour vapeur d'eau
+      PARAMETER (ivap=1)
+      INTEGER iliq          ! indice de traceurs pour eau liquide
+      PARAMETER (iliq=2)
+
+c
+c
+c Variables argument:
+c
+      INTEGER nlon
+      INTEGER nlev
+      INTEGER nqmax
+      REAL rjourvrai
+      REAL gmtime
+      REAL pdtphys
+      LOGICAL debut, lafin
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      REAL pphis(klon)
+      REAL presnivs(klev)
+      REAL znivsig(klev)
+      real pir
+
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL t(klon,klev)
+      REAL qx(klon,klev,nqmax)
+
+      REAL,allocatable,save :: t_ancien(:,:), q_ancien(:,:)
+c$OMP THREADPRIVATE(t_ancien, q_ancien)
+      LOGICAL ancien_ok
+      SAVE ancien_ok
+c$OMP THREADPRIVATE(ancien_ok)
+      REAL d_t_dyn(klon,klev)
+      REAL d_q_dyn(klon,klev)
+
+      REAL omega(klon,klev)
+
+#ifdef INCA
+      REAL flxmass_w(klon,klev)
+#endif
+      REAL d_u(klon,klev)
+      REAL d_v(klon,klev)
+      REAL d_t(klon,klev)
+      REAL d_qx(klon,klev,nqmax)
+      REAL d_ps(klon)
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+c
+cIM Amip2 PV a theta constante 
+c
+      INTEGER nbteta
+      PARAMETER(nbteta=3)
+      CHARACTER*3 ctetaSTD(nbteta)
+      DATA ctetaSTD/'350','380','405'/
+      SAVE ctetaSTD
+c$OMP THREADPRIVATE(ctetaSTD)
+      REAL rtetaSTD(nbteta)
+      DATA rtetaSTD/350., 380., 405./
+      SAVE rtetaSTD
+c$OMP THREADPRIVATE(rtetaSTD)     
+c
+      REAL PVteta(klon,nbteta)
+      REAL zx_tmp_3dte(iim,jjmp1,nbteta)
+c
+cMI Amip2 PV a theta constante
+
+cym      INTEGER klevp1, klevm1
+cym      PARAMETER(klevp1=klev+1,klevm1=klev-1)
+cym#include "raddim.h"
+c
+
+      REAL,allocatable,save :: swdn0(:,:), swdn(:,:)
+      REAL,allocatable,save :: swup0(:,:), swup(:,:)
+c$OMP THREADPRIVATE(swdn0 , swdn, swup0, swup)
+c
+      REAL,allocatable,save :: SWdn200clr(:), SWdn200(:)
+      REAL,allocatable,save :: SWup200clr(:), SWup200(:)
+c$OMP THREADPRIVATE(SWdn200clr, SWdn200, SWup200clr, SWup200)
+c
+      REAL,allocatable,save :: lwdn0(:,:), lwdn(:,:)
+      REAL,allocatable,save :: lwup0(:,:), lwup(:,:)
+c$OMP THREADPRIVATE(lwdn0 , lwdn, lwup0, lwup)
+c
+      REAL,allocatable,save :: LWdn200clr(:), LWdn200(:)
+      REAL,allocatable,save :: LWup200clr(:), LWup200(:)
+c$OMP THREADPRIVATE(LWdn200clr, LWdn200, LWup200clr, LWup200)
+c
+      REAL,allocatable,save :: LWdnTOA(:), LWdnTOAclr(:)
+c$OMP THREADPRIVATE(LWdnTOA, LWdnTOAclr)
+c
+cIM Amip2
+c variables a une pression donnee
+c
+      integer nlevSTD
+      PARAMETER(nlevSTD=17)
+      real rlevSTD(nlevSTD)
+      DATA rlevSTD/100000., 92500., 85000., 70000.,
+     .60000., 50000., 40000., 30000., 25000., 20000.,
+     .15000., 10000., 7000., 5000., 3000., 2000., 1000./
+      SAVE rlevstd
+c$OMP THREADPRIVATE(rlevSTD)
+      CHARACTER*4 clevSTD(nlevSTD)
+      DATA clevSTD/'1000','925 ','850 ','700 ','600 ',
+     .'500 ','400 ','300 ','250 ','200 ','150 ','100 ',
+     .'70  ','50  ','30  ','20  ','10  '/
+      SAVE clevSTD
+c$OMP THREADPRIVATE(clevSTD)
+c
+      CHARACTER*3 bb2
+      CHARACTER*2 bb3
+c
+      real tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD)
+      real rhlevSTD(klon,nlevSTD), philevSTD(klon,nlevSTD)
+      real ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD)
+      real wlevSTD(klon,nlevSTD) 
+c
+c nout : niveau de output des variables a une pression donnee
+      INTEGER nout
+      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+c
+      REAL,SAVE,ALLOCATABLE :: tsumSTD(:,:,:)
+      REAL,SAVE,ALLOCATABLE :: usumSTD(:,:,:), vsumSTD(:,:,:)
+      REAL,SAVE,ALLOCATABLE :: wsumSTD(:,:,:), phisumSTD(:,:,:)
+      REAL,SAVE,ALLOCATABLE :: qsumSTD(:,:,:), rhsumSTD(:,:,:)
+c$OMP THREADPRIVATE(tsumSTD, usumSTD, vsumSTD, wsumSTD, phisumSTD) 
+c$OMP THREADPRIVATE(qsumSTD, rhsumSTD)
+c
+      logical oknondef(klon,nlevSTD,nout)
+      real,SAVE,ALLOCATABLE :: tnondef(:,:,:) 
+c$OMP THREADPRIVATE(tnondef)
+c
+c les produits uvSTD, vqSTD, .., T2STD sont calcules
+c a partir des valeurs instantannees toutes les 6 h
+c qui sont moyennees sur le mois
+c
+      real uvSTD(klon,nlevSTD)
+      real vqSTD(klon,nlevSTD)
+      real vTSTD(klon,nlevSTD)
+      real wqSTD(klon,nlevSTD)
+c
+      real,save,allocatable :: uvsumSTD(:,:,:)
+      real,save,allocatable :: vqsumSTD(:,:,:)
+      real,save,allocatable :: vTsumSTD(:,:,:)
+      real,save,allocatable :: wqsumSTD(:,:,:)
+c
+      real vphiSTD(klon,nlevSTD)
+      real wTSTD(klon,nlevSTD)
+      real u2STD(klon,nlevSTD)
+      real v2STD(klon,nlevSTD)
+      real T2STD(klon,nlevSTD)
+c
+      real,save,allocatable :: vphisumSTD(:,:,:)
+      real,save,allocatable :: wTsumSTD(:,:,:)
+      real,save,allocatable :: u2sumSTD(:,:,:)
+      real,save,allocatable :: v2sumSTD(:,:,:)
+      real,save,allocatable :: T2sumSTD(:,:,:)
+c
+c$OMP THREADPRIVATE(uvsumSTD, vqsumSTD, vTsumSTD, wqsumSTD)
+c$OMP THREADPRIVATE(vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, T2sumSTD)
+
+cMI Amip2
+c
+#include "radepsi.h"
+#include "radopt.h"
+c
+c
+c prw: precipitable water
+      real prw(klon)
+
+      REAL convliq(klon,klev)  ! eau liquide nuageuse convective
+      REAL convfra(klon,klev)  ! fraction nuageuse convective
+
+      REAL cldl_c(klon),cldm_c(klon),cldh_c(klon) !nuages bas, moyen et haut
+      REAL cldt_c(klon),cldq_c(klon) !nuage total, eau liquide integree
+      REAL cldl_s(klon),cldm_s(klon),cldh_s(klon) !nuages bas, moyen et haut
+      REAL cldt_s(klon),cldq_s(klon) !nuage total, eau liquide integree
+
+      INTEGER linv, kp1
+c flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2)
+c flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg)
+      REAL flwp(klon), fiwp(klon)
+      REAL flwc(klon,klev), fiwc(klon,klev)
+      REAL flwp_c(klon), fiwp_c(klon)
+      REAL flwc_c(klon,klev), fiwc_c(klon,klev)
+      REAL flwp_s(klon), fiwp_s(klon)
+      REAL flwc_s(klon,klev), fiwc_s(klon,klev)
+
+cIM ISCCP simulator v3.4
+c dans clesphys.h top_height, overlap
+cv3.4
+      INTEGER debug, debugcol
+cym      INTEGER npoints
+cym      PARAMETER(npoints=klon) 
+c
+      INTEGER sunlit(klon) !sunlit=1 if day; sunlit=0 if night
+      INTEGER nregISCtot
+      PARAMETER(nregISCtot=1) 
+c
+c imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire
+c y compris pour 1 point
+c imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude)
+c jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude)
+      INTEGER imin_debut, nbpti
+      INTEGER jmin_debut, nbptj 
+cIM parametres ISCCP BEG
+      INTEGER nbapp_isccp
+!     INTEGER nbapp_isccp,isccppas
+!     PARAMETER(isccppas=6) !appel du simulateurs tous les 6pas de temps de la physique
+!                           !i.e. toutes les 3 heures 
+      INTEGER n, napisccp
+c     PARAMETER(napisccp=3)
+      PARAMETER(napisccp=1)
+      INTEGER ifreq_isccp(napisccp), freqin_pdt(napisccp)
+      DATA ifreq_isccp/3/
+      SAVE ifreq_isccp
+c$OMP THREADPRIVATE(ifreq_isccp)
+      CHARACTER*5 typinout(napisccp)
+      DATA typinout/'i3od'/
+      SAVE typinout
+c$OMP THREADPRIVATE(typinout)
+cIM verif boxptop BEG
+      CHARACTER*1 verticaxe(napisccp)
+      DATA verticaxe/'1'/ 
+      SAVE verticaxe
+c$OMP THREADPRIVATE(verticaxe)
+cIM verif boxptop END
+      INTEGER nvlev(napisccp)
+c     INTEGER nvlev
+      REAL t1, aa
+      REAL seed_re(klon,napisccp)
+      INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:)
+c$OMP THREADPRIVATE(seed_old)
+cym !!!! A voir plus tard 
+cym      INTEGER iphy(iim,jjmp1)
+cIM parametres ISCCP END
+c
+c ncol = nb. de sous-colonnes pour chaque maille du GCM 
+c ncolmx = No. max. de sous-colonnes pour chaque maille du GCM 
+c      INTEGER ncol(napisccp), ncolmx, seed(klon,napisccp)
+      INTEGER,SAVE :: ncol(napisccp)
+      INTEGER ncolmx, seed(klon,napisccp)
+      REAL nbsunlit(nregISCtot,klon,napisccp)  !nbsunlit : moyenne de sunlit
+c     PARAMETER(ncolmx=1500)
+      PARAMETER(ncolmx=300)
+c
+cIM verif boxptop BEG
+      REAL vertlev(ncolmx,napisccp)
+cIM verif boxptop END
+c
+      REAL,SAVE :: tautab_omp(0:255),tautab(0:255)
+      INTEGER,SAVE :: invtau_omp(-20:45000),invtau(-20:45000)
+c$OMP THREADPRIVATE(tautab,invtau)
+      REAL emsfc_lw
+      PARAMETER(emsfc_lw=0.99)
+c     REAL    ran0                      ! type for random number fuction
+c
+      REAL cldtot(klon,klev)
+c variables de haut en bas pour le simulateur ISCCP
+      REAL dtau_s(klon,klev) !tau nuages startiformes
+      REAL dtau_c(klon,klev) !tau nuages convectifs
+      REAL dem_s(klon,klev)  !emissivite nuages startiformes 
+      REAL dem_c(klon,klev)  !emissivite nuages convectifs
+c
+c variables de haut en bas pour le simulateur ISCCP
+      REAL pfull(klon,klev)
+      REAL phalf(klon,klev+1)
+      REAL qv(klon,klev)
+      REAL cc(klon,klev)
+      REAL conv(klon,klev)
+      REAL dtau_sH2B(klon,klev)
+      REAL dtau_cH2B(klon,klev)
+      REAL at(klon,klev)
+      REAL dem_sH2B(klon,klev)
+      REAL dem_cH2B(klon,klev)
+c
+      INTEGER kmax, lmax, lmax3
+      PARAMETER(kmax=8, lmax=8, lmax3=3)
+      INTEGER kmaxm1, lmaxm1
+      PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1)
+      INTEGER iimx7, jjmx7, jjmp1x7
+      PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1, 
+     .jjmp1x7=jjmp1*lmaxm1)
+c
+c output from ISCCP simulator
+      REAL fq_isccp(klon,kmaxm1,lmaxm1,napisccp)
+      REAL fq_is_true(klon,kmaxm1,lmaxm1,napisccp)
+      REAL totalcldarea(klon,napisccp) 
+      REAL meanptop(klon,napisccp)
+      REAL meantaucld(klon,napisccp)
+      REAL boxtau(klon,ncolmx,napisccp)
+      REAL boxptop(klon,ncolmx,napisccp) 
+      REAL zx_tmp_fi3d_bx(klon,ncolmx)
+      REAL zx_tmp_3d_bx(iim,jjmp1,ncolmx)
+c
+      REAL cld_fi3d(klon,lmax3)
+      REAL cld_3d(iim,jjmp1,lmax3)
+c
+      INTEGER iw, iwmax
+      REAL wmin, pas_w
+c     PARAMETER(wmin=-100.,pas_w=10.,iwmax=30)
+cIM 051005     PARAMETER(wmin=-200.,pas_w=10.,iwmax=40)
+      PARAMETER(wmin=-100.,pas_w=10.,iwmax=20)
+      REAL o500(klon)
+c
+cIM: nbregdyn = nbre regions pour calculs statistiques sur output du ISCCP
+cIM: dynamiques  
+      INTEGER nreg, nbregdyn
+      PARAMETER(nbregdyn=5)
+
+      INTEGER,ALLOCATABLE,SAVE :: pct_ocean(:,:)
+c$OMP THREADPRIVATE(pct_ocean)
+cym      SAVE pct_ocean
+ 
+c sorties ISCCP
+
+      integer nid_isccp
+      save nid_isccp        
+c$OMP THREADPRIVATE(nid_isccp)
+
+      REAL zx_tau(kmaxm1), zx_pc(lmaxm1), zx_o500(iwmax)
+      DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./
+      SAVE zx_tau
+      DATA zx_pc/180., 310., 440., 560., 680., 800., 1000./
+      SAVE zx_pc
+c$OMP THREADPRIVATE(zx_tau,zx_pc)
+c cldtopres pression au sommet des nuages
+      REAL cldtopres(lmaxm1), cldtopres3(lmax3)
+      DATA cldtopres/180., 310., 440., 560., 680., 800., 1000./
+      DATA cldtopres3/440., 680., 1000./
+      SAVE cldtopres,cldtopres3
+c$OMP THREADPRIVATE(cldtopres,cldtopres3)
+cIM 051005 BEG
+      REAL tmp_his1_3d(iwmax,kmaxm1,lmaxm1,nbregdyn,napisccp) 
+      REAL tmp_his2_3d(iwmax,kmaxm1,lmaxm1,nbregdyn,napisccp) 
+      REAL tmp_his3_3d(iwmax,kmaxm1,lmaxm1,nbregdyn,napisccp) 
+      INTEGER komega, nhoriRD 
+
+c taulev: numero du niveau de tau dans les sorties ISCCP
+      CHARACTER *4 taulev(kmaxm1)
+c     DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/
+      DATA taulev/'tau0','tau1','tau2','tau3','tau4','tau5','tau6'/
+      CHARACTER *3 pclev(lmaxm1)
+      DATA pclev/'pc1','pc2','pc3','pc4','pc5','pc6','pc7'/
+      SAVE taulev,pclev
+c$OMP THREADPRIVATE(taulev,pclev)
+c
+c cnameisccp
+      CHARACTER *27 cnameisccp(lmaxm1,kmaxm1)
+cIM bad 151205     DATA cnameisccp/'pc< 50hPa, tau< 0.3', 
+      DATA cnameisccp/'pc= 50-180hPa, tau< 0.3',
+     .                'pc= 180-310hPa, tau< 0.3',
+     .                'pc= 310-440hPa, tau< 0.3',
+     .                'pc= 440-560hPa, tau< 0.3',
+     .                'pc= 560-680hPa, tau< 0.3',
+     .                'pc= 680-800hPa, tau< 0.3',
+     .                'pc= 800-1000hPa, tau< 0.3',
+     .                'pc= 50-180hPa, tau= 0.3-1.3',
+     .                'pc= 180-310hPa, tau= 0.3-1.3',
+     .                'pc= 310-440hPa, tau= 0.3-1.3',
+     .                'pc= 440-560hPa, tau= 0.3-1.3',
+     .                'pc= 560-680hPa, tau= 0.3-1.3',
+     .                'pc= 680-800hPa, tau= 0.3-1.3',
+     .                'pc= 800-1000hPa, tau= 0.3-1.3',
+     .                'pc= 50-180hPa, tau= 1.3-3.6',
+     .                'pc= 180-310hPa, tau= 1.3-3.6',
+     .                'pc= 310-440hPa, tau= 1.3-3.6',
+     .                'pc= 440-560hPa, tau= 1.3-3.6',
+     .                'pc= 560-680hPa, tau= 1.3-3.6',
+     .                'pc= 680-800hPa, tau= 1.3-3.6',
+     .                'pc= 800-1000hPa, tau= 1.3-3.6',
+     .                'pc= 50-180hPa, tau= 3.6-9.4',
+     .                'pc= 180-310hPa, tau= 3.6-9.4',
+     .                'pc= 310-440hPa, tau= 3.6-9.4',
+     .                'pc= 440-560hPa, tau= 3.6-9.4',
+     .                'pc= 560-680hPa, tau= 3.6-9.4',
+     .                'pc= 680-800hPa, tau= 3.6-9.4',
+     .                'pc= 800-1000hPa, tau= 3.6-9.4',
+     .                'pc= 50-180hPa, tau= 9.4-23',
+     .                'pc= 180-310hPa, tau= 9.4-23',
+     .                'pc= 310-440hPa, tau= 9.4-23',
+     .                'pc= 440-560hPa, tau= 9.4-23',
+     .                'pc= 560-680hPa, tau= 9.4-23',
+     .                'pc= 680-800hPa, tau= 9.4-23',
+     .                'pc= 800-1000hPa, tau= 9.4-23',
+     .                'pc= 50-180hPa, tau= 23-60',
+     .                'pc= 180-310hPa, tau= 23-60',
+     .                'pc= 310-440hPa, tau= 23-60',
+     .                'pc= 440-560hPa, tau= 23-60',
+     .                'pc= 560-680hPa, tau= 23-60',
+     .                'pc= 680-800hPa, tau= 23-60',
+     .                'pc= 800-1000hPa, tau= 23-60',
+     .                'pc= 50-180hPa, tau> 60.',
+     .                'pc= 180-310hPa, tau> 60.',
+     .                'pc= 310-440hPa, tau> 60.',
+     .                'pc= 440-560hPa, tau> 60.',
+     .                'pc= 560-680hPa, tau> 60.',
+     .                'pc= 680-800hPa, tau> 60.',
+     .                'pc= 800-1000hPa, tau> 60.'/
+       SAVE cnameisccp
+c$OMP THREADPRIVATE(cnameisccp)
+c
+c     REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7)
+c     INTEGER nhorix7
+cIM: region='3d' <==> sorties en global
+      CHARACTER*3 region
+      PARAMETER(region='3d')
+c
+cIM ISCCP simulator v3.4
+c
+      logical ok_hf
+c
+      integer nid_hf, nid_hf3d
+      save ok_hf, nid_hf, nid_hf3d
+c$OMP THREADPRIVATE(ok_hf, nid_hf, nid_hf3d)
+c  QUESTION : noms de variables ?
+
+c#ifdef histhf
+c      data ok_hf/.true./
+c#else
+c      data ok_hf/.false./
+c#endif
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles      )
+c
+c Variables quasi-arguments
+c
+      REAL xjour
+      SAVE xjour
+c$OMP THREADPRIVATE(xjour)
+c
+c
+c Variables propres a la physique
+c
+      REAL dtime
+      SAVE dtime                  ! pas temporel de la physique
+c$OMP THREADPRIVATE(dtime)
+c
+      INTEGER radpas
+      SAVE radpas                 ! frequence d'appel rayonnement
+c$OMP THREADPRIVATE(radpas)
+c
+      REAL,allocatable,save :: radsol(:)
+c$OMP THREADPRIVATE(radsol)
+cym      SAVE radsol               ! bilan radiatif au sol calcule par code radiatif
+c
+      REAL,allocatable,save :: rlat(:)
+c$OMP THREADPRIVATE(rlat)
+cym      SAVE rlat                   ! latitude pour chaque point
+c
+      REAL,allocatable,save :: rlon(:)
+c$OMP THREADPRIVATE(rlon)
+cym      SAVE rlon                   ! longitude pour chaque point
+
+      REAL,SAVE,ALLOCATABLE :: rlonPOS(:)
+c$OMP THREADPRIVATE(rlonPOS)    
+cym      SAVE rlonPOS                ! longitudes > 0. pour chaque point
+c
+cc      INTEGER iflag_con
+cc      SAVE iflag_con              ! indicateur de la convection
+c
+      INTEGER itap
+      SAVE itap                   ! compteur pour la physique
+c$OMP THREADPRIVATE(itap)
+c
+      REAL co2_ppm_etat0
+c
+      REAL solaire_etat0
+c
+      real slp(klon) ! sea level pressure
+
+      REAL,allocatable,save :: ftsol(:,:)
+c$OMP THREADPRIVATE(ftsol)       ! temperature du sol
+
+cIM
+      REAL,SAVE,ALLOCATABLE :: newsst(:) !temperature de l'ocean
+c$OMP THREADPRIVATE(newsst)
+cym     SAVE newsst
+c
+      REAL fevap(klon,nbsrf)
+      REAL fluxlat(klon,nbsrf)
+c
+      REAL,allocatable,save :: deltat(:)
+c$OMP THREADPRIVATE(deltat)
+cym      SAVE deltat                 ! ecart avec la SST de reference
+c
+      REAL qsol(klon)
+c
+      REAL,allocatable,save :: falbe(:,:)
+c$OMP THREADPRIVATE(falbe)       ! albedo par type de surface
+c
+      REAL,allocatable,save :: falblw(:,:)
+c$OMP THREADPRIVATE(falblw)       ! albedo par type de surface
+
+c
+c
+c  Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
+c
+      REAL,allocatable,save :: zmea(:)
+c$OMP THREADPRIVATE(zmea)
+cym      SAVE zmea                   ! orographie moyenne
+c
+      REAL,allocatable,save :: zstd(:)
+c$OMP THREADPRIVATE(zstd)
+cym      SAVE zstd                   ! deviation standard de l'OESM
+c
+      REAL,allocatable,save :: zsig(:)
+c$OMP THREADPRIVATE(zsig)
+cym      SAVE zsig                   ! pente de l'OESM
+c
+      REAL,allocatable,save :: zgam(:)
+c$OMP THREADPRIVATE(zgam)
+cym      save zgam                   ! anisotropie de l'OESM
+c
+      REAL,allocatable,save :: zthe(:)
+c$OMP THREADPRIVATE(zthe)      
+cym      SAVE zthe                   ! orientation de l'OESM
+c
+      REAL,allocatable,save :: zpic(:)
+c$OMP THREADPRIVATE(zpic)
+cym      SAVE zpic                   ! Maximum de l'OESM
+c
+      REAL,allocatable,save :: zval(:)
+c$OMP THREADPRIVATE(zval)
+cym      SAVE zval                   ! Minimum de l'OESM
+c
+      REAL,allocatable,save :: rugoro(:)
+c$OMP THREADPRIVATE(rugoro)
+cym      SAVE rugoro                 ! longueur de rugosite de l'OESM
+c
+cIM 141004     REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
+      REAL zulow(klon),zvlow(klon)
+c
+      REAL,allocatable,save :: zuthe(:),zvthe(:)
+c$OMP THREADPRIVATE(zuthe,zvthe)
+cym      SAVE zuthe
+cym      SAVE zvthe
+      INTEGER igwd,idx(klon),itest(klon)
+c
+      REAL agesno(klon,nbsrf)
+c
+      REAL,allocatable,save :: alb_neig(:)
+c$OMP THREADPRIVATE(alb_neig)
+cym      SAVE alb_neig               ! albedo de la neige
+c
+c      REAL,allocatable,save :: run_off_lic_0(:)
+cc$OMP THREADPRIVATE(run_off_lic_0)
+cym      SAVE run_off_lic_0
+cKE43
+c Variables liees a la convection de K. Emanuel (sb):
+c
+      REAL,allocatable,save :: ema_workcbmf(:)   ! cloud base mass flux
+c$OMP THREADPRIVATE(ema_workcbmf)
+cym      SAVE ema_workcbmf
+
+      REAL,allocatable,save :: ema_cbmf(:)       ! cloud base mass flux
+c$OMP THREADPRIVATE(ema_cbmf)
+cym      SAVE ema_cbmf
+
+      REAL,allocatable,save :: ema_pcb(:)        ! cloud base pressure
+c$OMP THREADPRIVATE(ema_pcb)
+cym      SAVE ema_pcb
+
+      REAL,allocatable,save :: ema_pct(:)        ! cloud top pressure
+c$OMP THREADPRIVATE(ema_pct)
+cym      SAVE ema_pct
+
+      REAL bas, top             ! cloud base and top levels
+      SAVE bas
+      SAVE top
+c$OMP THREADPRIVATE(bas, top)
+
+      REAL,allocatable,save :: Ma(:,:)        ! undilute upward mass flux
+c$OMP THREADPRIVATE(Ma)
+cym      SAVE Ma
+      REAL,allocatable,save :: qcondc(:,:)    ! in-cld water content from convect
+c$OMP THREADPRIVATE(qcondc)
+cym      SAVE qcondc 
+      REAL,allocatable,save :: ema_work1(:, :), ema_work2(:, :)
+c$OMP THREADPRIVATE(ema_work1,ema_work2)
+cym      SAVE ema_work1, ema_work2
+      REAL wdn(klon), tdn(klon), qdn(klon)
+
+      REAL,allocatable,save :: wd(:) ! sb
+c$OMP THREADPRIVATE(wd)
+cym      SAVE wd       ! sb
+
+c Variables locales pour la couche limite (al1):
+c
+cAl1      REAL pblh(klon)           ! Hauteur de couche limite
+cAl1      SAVE pblh
+c34EK
+c
+c Variables locales:
+c
+      REAL cdragh(klon) ! drag coefficient pour T and Q
+      REAL cdragm(klon) ! drag coefficient pour vent
+cAA
+cAA  Pour phytrac 
+cAA
+      REAL ycoefh(klon,klev)    ! coef d'echange pour phytrac
+      REAL yu1(klon)            ! vents dans la premiere couche U
+      REAL yv1(klon)            ! vents dans la premiere couche V
+
+      REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon)
+
+c@$$      LOGICAL offline           ! Controle du stockage ds "physique"
+c@$$      PARAMETER (offline=.false.)
+c@$$      INTEGER physid
+      REAL,allocatable,save :: pfrac_impa(:,:)! Produits des coefs lessivage impaction
+c$OMP THREADPRIVATE(pfrac_impa)
+cym      save pfrac_impa
+      REAL,allocatable,save :: pfrac_nucl(:,:)! Produits des coefs lessivage nucleation
+c$OMP THREADPRIVATE(pfrac_nucl)
+cym      save pfrac_nucl
+      REAL,allocatable,save :: pfrac_1nucl(:,:)! Produits des coefs lessi nucl (alpha = 1)
+c$OMP THREADPRIVATE(pfrac_1nucl)
+cym      save pfrac_1nucl
+      REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
+      REAL frac_nucl(klon,klev) ! idem (nucleation)
+#ifdef INCA
+      INTEGER       :: iii
+      REAL          :: calday
+#endif
+
+cAA
+      REAL,allocatable,save :: rain_fall(:) ! pluie
+c$OMP THREADPRIVATE(rain_fall)
+      REAL,allocatable,save :: snow_fall(:) ! neige
+c$OMP THREADPRIVATE(snow_fall)
+cym      save snow_fall, rain_fall
+
+cIM cf FH pour Tiedtke 080604
+      REAL rain_tiedtke(klon),snow_tiedtke(klon)
+c
+
+      REAL,allocatable,save :: total_rain(:), nday_rain(:)
+c$OMP THREADPRIVATE(total_rain,nday_rain)
+cym      save total_rain, nday_rain
+cIM 050204 END
+      REAL evap(klon), devap(klon) ! evaporation et sa derivee
+      REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
+
+      REAL bils(klon) ! bilan de chaleur au sol
+      REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque
+C                             ! type de sous-surface et pondere par la fraction
+      REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque
+C                             ! type de sous-surface et pondere par la fraction
+      REAL fder(klon)         
+      REAL ve(klon) ! integr. verticale du transport meri. de l'energie
+      REAL vq(klon) ! integr. verticale du transport meri. de l'eau
+      REAL ue(klon) ! integr. verticale du transport zonal de l'energie
+      REAL uq(klon) ! integr. verticale du transport zonal de l'eau
+c
+      REAL frugs(klon,nbsrf)
+      REAL zxrugs(klon) ! longueur de rugosite
+c
+c Conditions aux limites
+c
+      INTEGER julien
+c
+      INTEGER lmt_pas
+      SAVE lmt_pas                ! frequence de mise a jour
+c$OMP THREADPRIVATE(lmt_pas) 
+      REAL,allocatable,save :: pctsrf(:,:)
+c$OMP THREADPRIVATE(pctsrf) 
+cIM
+      REAL pctsrf_new(klon,nbsrf) !pourcentage surfaces issus d'ORCHIDEE
+
+cym      REAL paire_ter(klon)        !surfaces terre 
+      REAL,allocatable,save ::  paire_ter(:)        !surfaces terre 
+c$OMP THREADPRIVATE(paire_ter) 
+    
+cIM
+cym      SAVE pctsrf                 ! sous-fraction du sol
+      REAL,allocatable,save :: albsol(:)
+c$OMP THREADPRIVATE(albsol)
+cym      SAVE albsol                 ! albedo du sol total
+      REAL,allocatable,save :: albsollw(:)
+c$OMP THREADPRIVATE(albsollw)      
+cym      SAVE albsollw                 ! albedo du sol total
+
+      REAL,allocatable,save :: wo(:,:)
+c$OMP THREADPRIVATE(wo)
+cym     SAVE wo                     ! ozone
+
+cIM sorties
+      REAL un_jour
+      PARAMETER(un_jour=86400.)
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+      EXTERNAL angle     ! calculer angle zenithal du soleil
+      EXTERNAL alboc     ! calculer l'albedo sur ocean
+      EXTERNAL ajsec     ! ajustement sec
+      EXTERNAL conlmd    ! convection (schema LMD)
+cKE43
+      EXTERNAL conema3  ! convect4.3
+      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
+cAA 
+      EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
+c                          ! stockage des coefficients necessaires au
+c                          ! lessivage OFF-LINE et ON-LINE
+      EXTERNAL hgardfou  ! verifier les temperatures
+      EXTERNAL nuage     ! calculer les proprietes radiatives
+      EXTERNAL o3cm      ! initialiser l'ozone
+      EXTERNAL orbite    ! calculer l'orbite terrestre
+      EXTERNAL ozonecm   ! prescrire l'ozone
+      EXTERNAL phyetat0  ! lire l'etat initial de la physique
+      EXTERNAL phyredem  ! ecrire l'etat de redemarrage de la physique
+      EXTERNAL radlwsw   ! rayonnements solaire et infrarouge
+      EXTERNAL suphec    ! initialiser certaines constantes
+      EXTERNAL transp    ! transport total de l'eau et de l'energie
+      EXTERNAL ecribina  ! ecrire le fichier binaire global
+      EXTERNAL ecribins  ! ecrire le fichier binaire global
+      EXTERNAL ecrirega  ! ecrire le fichier binaire regional
+      EXTERNAL ecriregs  ! ecrire le fichier binaire regional
+cIM
+      EXTERNAL haut2bas  !variables de haut en bas
+      INTEGER lnblnk1
+      EXTERNAL lnblnk1   !enleve les blancs a la fin d'une variable de type
+                         !caracter
+      EXTERNAL ini_undefSTD  !initialise a 0 une variable a 1 niveau de pression
+      EXTERNAL undefSTD      !somme les valeurs definies d'1 var a 1 niveau de pression
+c     EXTERNAL moy_undefSTD  !moyenne d'1 var a 1 niveau de pression
+c     EXTERNAL moyglo_aire   !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire)
+c                            !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
+c
+c Variables locales
+c
+      real,allocatable,save :: clwcon(:,:),rnebcon(:,:)
+c$OMP THREADPRIVATE(clwcon,rnebcon)
+      real,allocatable,save :: clwcon0(:,:),rnebcon0(:,:)
+cym      save rnebcon, clwcon
+c$OMP THREADPRIVATE(clwcon0,rnebcon0)
+      REAL rhcl(klon,klev)    ! humiditi relative ciel clair
+      REAL dialiq(klon,klev)  ! eau liquide nuageuse
+      REAL diafra(klon,klev)  ! fraction nuageuse
+      REAL cldliq(klon,klev)  ! eau liquide nuageuse
+      REAL cldfra(klon,klev)  ! fraction nuageuse
+      REAL cldtau(klon,klev)  ! epaisseur optique
+      REAL cldemi(klon,klev)  ! emissivite infrarouge
+c
+CXXX PB 
+      REAL fluxq(klon,klev, nbsrf)   ! flux turbulent d'humidite
+      REAL fluxt(klon,klev, nbsrf)   ! flux turbulent de chaleur
+      REAL fluxu(klon,klev, nbsrf)   ! flux turbulent de vitesse u
+      REAL fluxv(klon,klev, nbsrf)   ! flux turbulent de vitesse v
+c
+      REAL zxfluxt(klon, klev)
+      REAL zxfluxq(klon, klev)
+      REAL zxfluxu(klon, klev)
+      REAL zxfluxv(klon, klev)
+CXXX
+      REAL,allocatable,save :: heat(:,:)    ! chauffage solaire
+c$OMP THREADPRIVATE(heat)
+      REAL,allocatable,save :: heat0(:,:)   ! chauffage solaire ciel clair
+c$OMP THREADPRIVATE(heat0)
+      REAL,allocatable,save :: cool(:,:)    ! refroidissement infrarouge
+c$OMP THREADPRIVATE(cool)
+      REAL,allocatable,save :: cool0(:,:)   ! refroidissement infrarouge ciel clair
+c$OMP THREADPRIVATE(cool0)
+      REAL,allocatable,save :: topsw(:), toplw(:), solsw(:), sollw(:)
+c$OMP THREADPRIVATE(topsw,toplw,solsw,sollw)
+      real,allocatable,save :: sollwdown(:)    ! downward LW flux at surface
+c$OMP THREADPRIVATE(sollwdown)
+cIM BEG
+      real,allocatable,save :: sollwdownclr(:)    ! downward CS LW flux at surface 
+c$OMP THREADPRIVATE(sollwdownclr)
+      real,allocatable,save :: toplwdown(:)       ! downward CS LW flux at TOA
+c$OMP THREADPRIVATE(toplwdown)
+      real,allocatable,save :: toplwdownclr(:)    ! downward CS LW flux at TOA
+c$OMP THREADPRIVATE(toplwdownclr)
+cIM END
+      REAL,allocatable,save :: topsw0(:),toplw0(:),solsw0(:),sollw0(:)
+c$OMP THREADPRIVATE( topsw0,toplw0,solsw0,sollw0)
+      REAL,allocatable,save :: albpla(:)
+c$OMP THREADPRIVATE(albpla)
+      REAL fsollw(klon, nbsrf)   ! bilan flux IR pour chaque sous surface
+      REAL fsolsw(klon, nbsrf)   ! flux solaire absorb. pour chaque sous surface
+c Le rayonnement n'est pas calcule tous les pas, il faut donc
+c                      sauvegarder les sorties du rayonnement
+cym      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
+cym      SAVE  sollwdownclr, toplwdown, toplwdownclr
+cym      SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
+c
+      INTEGER itaprad
+      SAVE itaprad
+c$OMP THREADPRIVATE(itaprad)
+c
+      REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
+      REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
+c
+      REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut
+      REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
+c
+      REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon)
+      REAL zxsnow_dummy(klon)
+c
+      REAL dist, rmu0(klon), fract(klon)
+      REAL zdtime, zlongi
+c
+      CHARACTER*2 str2
+      CHARACTER*2 iqn
+c
+      REAL qcheck
+      REAL z_avant(klon), z_apres(klon), z_factor(klon)
+      LOGICAL zx_ajustq
+c
+      REAL za, zb
+      REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
+      real zqsat(klon,klev)
+      INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zphi(klon,klev)
+cym A voir plus tard !!
+cym      REAL zx_relief(iim,jjmp1)
+cym      REAL zx_aire(iim,jjmp1)
+c
+c Grandeurs de sorties
+      REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)
+      REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)
+      REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon)
+      REAL s_trmb3(klon)
+cKE43
+c Variables locales pour la convection de K. Emanuel (sb):
+c
+      REAL upwd(klon,klev)      ! saturated updraft mass flux
+      REAL dnwd(klon,klev)      ! saturated downdraft mass flux
+      REAL dnwd0(klon,klev)     ! unsaturated downdraft mass flux
+      REAL tvp(klon,klev)       ! virtual temp of lifted parcel
+      REAL,allocatable,save :: cape(:)           ! CAPE
+c$OMP THREADPRIVATE(cape)
+cym      SAVE cape
+      CHARACTER*40 capemaxcels  !max(CAPE)
+
+      REAL,allocatable,save :: pbase(:)          ! cloud base pressure
+c$OMP THREADPRIVATE(pbase)
+cym      SAVE pbase
+      REAL,allocatable,save :: bbase(:)          ! cloud base buoyancy
+c$OMP THREADPRIVATE(bbase)
+cym      SAVE bbase
+      REAL rflag(klon)          ! flag fonctionnement de convect
+      INTEGER iflagctrl(klon)          ! flag fonctionnement de convect
+c -- convect43:
+      INTEGER ntra              ! nb traceurs pour convect4.3
+      REAL pori_con(klon)    ! pressure at the origin level of lifted parcel
+      REAL plcl_con(klon),dtma_con(klon),dtlcl_con(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+c?     .     condm_con(klon,klev),conda_con(klon,klev),
+c?     .     mr_con(klon,klev),ep_con(klon,klev)
+c?     .    ,sadiab(klon,klev),wadiab(klon,klev)
+c --
+c34EK
+c
+c Variables du changement
+c
+c con: convection
+c lsc: condensation a grande echelle (Large-Scale-Condensation)
+c ajs: ajustement sec
+c eva: evaporation de l'eau liquide nuageuse
+c vdf: couche limite (Vertical DiFfusion)
+      REAL d_t_con(klon,klev),d_q_con(klon,klev)
+      REAL,SAVE,ALLOCATABLE :: d_u_con(:,:),d_v_con(:,:)
+c$OMP THREADPRIVATE(d_u_con,d_v_con)
+      REAL d_t_lsc(klon,klev),d_q_lsc(klon,klev),d_ql_lsc(klon,klev)
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_u_ajs(klon,klev), d_v_ajs(klon,klev)
+      REAL d_t_eva(klon,klev),d_q_eva(klon,klev)
+      REAL d_t_oli(klon,klev) !tendances dues a oro et lif 
+      REAL rneb(klon,klev)
+c
+*********************************************************
+*     declarations
+      real,save,allocatable :: zqasc(:,:)
+c$OMP THREADPRIVATE(zqasc)
+cym      save zqasc
+      
+*********************************************************
+cIM 081204 END
+c
+      REAL pmfu(klon,klev), pmfd(klon,klev)
+      REAL pen_u(klon,klev), pen_d(klon,klev)
+      REAL pde_u(klon,klev), pde_d(klon,klev)
+      INTEGER kcbot(klon), kctop(klon), kdtop(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      REAL prfl(klon,klev+1), psfl(klon,klev+1)
+c
+      INTEGER,allocatable,save :: ibas_con(:), itop_con(:)
+c$OMP THREADPRIVATE(ibas_con,itop_con)
+cym
+cym      SAVE ibas_con,itop_con
+cym
+      REAL,SAVE,ALLOCATABLE :: rain_con(:)
+c$OMP THREADPRIVATE(rain_con)
+      REAL rain_lsc(klon)
+      REAL,SAVE,ALLOCATABLE :: snow_con(:)
+c$OMP THREADPRIVATE(snow_con)
+      REAL snow_lsc(klon)
+      REAL d_ts(klon,nbsrf)
+c
+      REAL d_u_vdf(klon,klev), d_v_vdf(klon,klev)
+      REAL d_t_vdf(klon,klev), d_q_vdf(klon,klev)
+c
+      REAL d_u_oro(klon,klev), d_v_oro(klon,klev)
+      REAL d_t_oro(klon,klev)
+      REAL d_u_lif(klon,klev), d_v_lif(klon,klev)
+      REAL d_t_lif(klon,klev)
+      REAL d_u_oli(klon,klev), d_v_oli(klon,klev) !tendances dues a oro et lif 
+
+      REAL,allocatable,save :: ratqs(:,:)
+c$OMP THREADPRIVATE(ratqs)
+      REAL ratqss(klon,klev),ratqsc(klon,klev)
+      real ratqsbas,ratqshaut
+cym      save ratqsbas,ratqshaut, ratqs
+      save ratqsbas,ratqshaut
+c$OMP THREADPRIVATE(ratqsbas,ratqshaut)
+      real zpt_conv(klon,klev)
+
+c Parametres lies au nouveau schema de nuages (SB, PDF)
+      real fact_cldcon
+      real facttemps
+      logical ok_newmicro
+      save ok_newmicro
+c$OMP THREADPRIVATE(ok_newmicro)
+      save fact_cldcon,facttemps
+c$OMP THREADPRIVATE(fact_cldcon,facttemps)
+      real facteur
+
+      integer iflag_cldcon
+      save iflag_cldcon
+c$OMP THREADPRIVATE(iflag_cldcon)
+      logical ptconv(klon,klev)
+cIM cf. AM 081204 BEG
+      logical ptconvth(klon,klev)
+cIM cf. AM 081204 END
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c======================================================================
+c
+cIM cf. AM 081204 BEG
+c   declarations pour sortir sur une sous-region
+      integer imin_ins,imax_ins,jmin_ins,jmax_ins
+      save imin_ins,imax_ins,jmin_ins,jmax_ins
+c$OMP THREADPRIVATE(imin_ins,imax_ins,jmin_ins,jmax_ins)
+c      real lonmin_ins,lonmax_ins,latmin_ins
+c     s  ,latmax_ins
+c     data lonmin_ins,lonmax_ins,latmin_ins
+c    s  ,latmax_ins/
+c valeurs initiales     s   -5.,20.,41.,55./   
+c    s   100.,130.,-20.,20./
+c    s   -180.,180.,-90.,90./
+c======================================================================
+cIM cf. AM 081204 END
+
+c
+      integer itau_w   ! pas de temps ecriture = itap + itau_phy
+c
+c
+c Variables locales pour effectuer les appels en serie
+c
+      REAL t_seri(klon,klev), q_seri(klon,klev)
+      REAL ql_seri(klon,klev),qs_seri(klon,klev)
+      REAL u_seri(klon,klev), v_seri(klon,klev)
+c
+      REAL tr_seri(klon,klev,nbtr)
+      REAL d_tr(klon,klev,nbtr)
+
+      REAL zx_rh(klon,klev)
+cIM RH a 2m (la surface)
+      REAL rh2m(klon), qsat2m(klon)
+      REAL tpot(klon), tpote(klon)
+      REAL Lheat
+
+      INTEGER        length
+      PARAMETER    ( length = 100 )
+      REAL tabcntr0( length       )
+c
+      INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev)
+cIM
+      INTEGER ndex2d1(iwmax)
+c
+cIM AMIP2 BEG
+      REAL moyglo, mountor
+cIM 141004 BEG
+      REAL zustrdr(klon), zvstrdr(klon)
+      REAL zustrli(klon), zvstrli(klon)
+      REAL zustrph(klon), zvstrph(klon)
+      REAL aam, torsfc
+cIM 141004 END
+cIM 190504 BEG
+      INTEGER ij, imp1jmp1
+      PARAMETER(imp1jmp1=(iim+1)*jjmp1)
+cym A voir plus tard
+      REAL zx_tmp(imp1jmp1), airedyn(iim+1,jjmp1)
+      REAL padyn(iim+1,jjmp1,klev+1)
+      REAL dudyn(iim+1,jjmp1,klev)
+      REAL rlatdyn(iim+1,jjmp1)
+cIM 190504 END
+      LOGICAL ok_msk
+      REAL msk(klon)
+cIM 
+      REAL airetot, pi
+cym A voir plus tard
+cym      REAL zm_wo(jjmp1, klev)
+cIM AMIP2 END
+c
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+c#ifdef histmthNMC
+cym   A voir plus tard !!!!
+cym      REAL zx_tmp_NC(iim,jjmp1,nlevSTD)
+      REAL zx_tmp_fiNC(klon,nlevSTD) 
+c#endif
+      REAL*8 zx_tmp2_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev)
+      REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1)
+c
+      INTEGER nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri
+      INTEGER nid_ctesGCM
+      SAVE nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri
+      SAVE nid_ctesGCM
+c$OMP THREADPRIVATE(nid_day, nid_mth, nid_ins, nid_nmc)
+c$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM)
+c
+cIM 280405 BEG
+      INTEGER nid_bilKPins, nid_bilKPave
+      SAVE nid_bilKPins, nid_bilKPave
+c$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave)
+c
+      REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert.
+      REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert.
+      REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert.
+      REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert.
+c
+cIM 280405 END
+c
+      INTEGER nhori, nvert, nvert1, nvert3
+      REAL zsto, zsto1, zsto2
+      REAL zstophy, zstorad, zstohf, zstoday, zstomth, zout
+      REAL zcals(napisccp), zcalh(napisccp), zoutj(napisccp)
+      REAL zout_isccp(napisccp)
+      SAVE zcals, zcalh, zoutj, zout_isccp
+c$OMP THREADPRIVATE(zcals, zcalh, zoutj, zout_isccp)
+
+      real zjulian
+      save zjulian
+c$OMP THREADPRIVATE(zjulian)
+
+      character*20 modname
+      character*80 abort_message
+      logical ok_sync
+      real date0
+      integer idayref
+
+C essai writephys
+      integer fid_day, fid_mth, fid_ins
+      parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 
+      integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
+      parameter (prof2d_on = 1, prof3d_on = 2,
+     .           prof2d_av = 3, prof3d_av = 4)
+      character*30 nom_fichier
+      character*10 varname
+      character*40 vartitle
+      character*20 varunits
+C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot,
+c$OMP+              h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+c$OMP THREADPRIVATE(d_h_vcol_phy)
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/0/
+c$OMP THREADPRIVATE(ip_ebil)
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+c$OMP THREADPRIVATE(if_ebil)
+c+jld ec_conser
+      REAL d_t_ec(klon,klev)    ! tendance du a la conersion Ec -> E thermique
+      REAL ZRCPD
+c-jld ec_conser
+      REAL t2m(klon,nbsrf)  ! temperature a 2m
+      REAL q2m(klon,nbsrf)  ! humidite a 2m
+
+cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels
+      REAL,SAVE,ALLOCATABLE :: u10m(:,:), v10m(:,:) !vents a 10m
+c$OMP THREADPRIVATE(u10m,v10m)
+      REAL zt2m(klon), zq2m(klon)             !temp., hum. 2m moyenne s/ 1 maille
+      REAL zu10m(klon), zv10m(klon)           !vents a 10m moyennes s/1 maille
+      CHARACTER*40 t2mincels, t2maxcels       !t2m min., t2m max
+      CHARACTER*40 tinst, tave, typeval
+cjq   Aerosol effects (Johannes Quaas, 27/11/2003)
+      REAL sulfate(klon, klev) ! SO4 aerosol concentration [ug/m3]
+      REAL,allocatable,save :: sulfate_pi(:,:) ! SO4 aerosol concentration [ug/m3] (pre-industrial value)
+c$OMP THREADPRIVATE(sulfate_pi)
+cym      SAVE sulfate_pi
+
+      REAL cldtaupi(klon,klev)  ! Cloud optical thickness for pre-industrial (pi) aerosols
+
+      REAL re(klon, klev)       ! Cloud droplet effective radius
+      REAL fl(klon, klev)  ! denominator of re
+
+      REAL re_top(klon), fl_top(klon) ! CDR at top of liquid water clouds
+
+      ! Aerosol optical properties
+      REAL,SAVE,ALLOCATABLE :: tau_ae(:,:,:), piz_ae(:,:,:)
+c$OMP THREADPRIVATE(tau_ae,piz_ae)
+      REAL,SAVE,ALLOCATABLE :: cg_ae(:,:,:)
+c$OMP THREADPRIVATE(cg_ae)
+
+#ifdef INCA_AER
+#ifdef CPP_COUPLE
+! Aerosol optical properties by INCA model 
+      REAL, SAVE, ALLOCATABLE  ::    tau_inca(:,:,:,:)
+      REAL, SAVE, ALLOCATABLE  ::    piz_inca(:,:,:,:)
+      REAL, SAVE, ALLOCATABLE  ::    cg_inca(:,:,:,:)
+      REAL, SAVE, ALLOCATABLE  ::    ccm(:,:,:) 
+      CHARACTER*4              ::    rfname(9) 
+
+      REAL,SAVE,ALLOCATABLE :: topswad_inca(:), solswad_inca(:) ! Aerosol direct effect.
+      REAL,SAVE,ALLOCATABLE :: topswad0_inca(:), solswad0_inca(:) ! Aerosol direct effect.
+      REAL,SAVE,ALLOCATABLE :: topswai_inca(:), solswai_inca(:) ! Aerosol indirect effect.
+      REAL,SAVE,ALLOCATABLE :: topsw_inca(:,:), solsw_inca(:,:) 
+      REAL,SAVE,ALLOCATABLE :: topsw0_inca(:,:), solsw0_inca(:,:)
+#endif
+#endif
+      REAL,SAVE,ALLOCATABLE :: topswad(:), solswad(:) ! Aerosol direct effect.
+c$OMP THREADPRIVATE(topswad,solswad)
+      ! ok_ade=T -ADE=topswad-topsw
+
+      REAL,SAVE,ALLOCATABLE :: topswai(:), solswai(:) ! Aerosol indirect effect.
+c$OMP THREADPRIVATE(topswai,solswai)
+      ! ok_aie=T ->
+      !        ok_ade=T -AIE=topswai-topswad
+      !        ok_ade=F -AIE=topswai-topsw
+
+      REAL aerindex(klon)       ! POLDER aerosol index
+     
+      ! Parameters
+      LOGICAL ok_ade, ok_aie    ! Apply aerosol (in)direct effects or not
+      REAL bl95_b0, bl95_b1   ! Parameter in Boucher and Lohmann (1995)
+cym 
+      SAVE ok_ade, ok_aie, bl95_b0, bl95_b1
+c$OMP THREADPRIVATE(ok_ade, ok_aie, bl95_b0, bl95_b1)
+
+c
+c Declaration des constantes et des fonctions thermodynamiques
+c
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+cIM 100106 BEG : pouvoir sortir les ctes de la physique
+#include "conema3.h"
+#include "fisrtilp.h"
+#include "nuage.h"
+#include "compbl.h"
+cIM 100106 END : pouvoir sortir les ctes de la physique
+c
+c======================================================================
+
+cym => necessaire pour iflag_con != 2    
+      pmfd(:,:) = 0.
+      pen_u(:,:) = 0.
+      pen_d(:,:) = 0.
+      pde_d(:,:) = 0.
+      pde_u(:,:) = 0.
+      aam=0.
+      torsfc=0.
+
+      if (first) then 
+      
+      allocate( t_ancien(klon,klev), q_ancien(klon,klev))
+      allocate( swdn0(klon,klevp1), swdn(klon,klevp1))
+      allocate( swup0(klon,klevp1), swup(klon,klevp1))
+      allocate( SWdn200clr(klon), SWdn200(klon))
+      allocate( SWup200clr(klon), SWup200(klon))
+      allocate( lwdn0(klon,klevp1), lwdn(klon,klevp1))
+      allocate( lwup0(klon,klevp1), lwup(klon,klevp1))
+      allocate( LWdn200clr(klon), LWdn200(klon))
+      allocate( LWup200clr(klon), LWup200(klon))
+      allocate( LWdnTOA(klon), LWdnTOAclr(klon))
+      allocate( radsol(klon))
+      allocate( rlat(klon))
+      allocate( rlon(klon))
+      allocate( ftsol(klon,nbsrf))
+      allocate( deltat(klon))
+      allocate( falbe(klon,nbsrf))
+      allocate( falblw(klon,nbsrf))
+      allocate( zmea(klon))
+      allocate( zstd(klon))
+      allocate( zsig(klon))
+      allocate( zgam(klon))
+      allocate( zthe(klon))
+      allocate( zpic(klon))
+      allocate( zval(klon))
+      allocate( rugoro(klon))
+      allocate( zuthe(klon),zvthe(klon))
+      allocate( alb_neig(klon))
+      allocate( ema_workcbmf(klon))   
+      allocate( ema_cbmf(klon)) 
+      allocate( ema_pcb(klon))
+      allocate( ema_pct(klon))  
+      allocate( Ma(klon,klev) )
+      allocate( qcondc(klon,klev))  
+      allocate( ema_work1(klon, klev), ema_work2(klon, klev))
+      allocate( wd(klon) )
+      allocate( pfrac_impa(klon,klev))
+      allocate( pfrac_nucl(klon,klev))
+      allocate( pfrac_1nucl(klon,klev))
+      allocate( rain_fall(klon) )
+      allocate( snow_fall(klon) )
+      allocate( total_rain(klon), nday_rain(klon))
+      allocate( pctsrf(klon,nbsrf))
+      allocate( albsol(klon))
+      allocate( albsollw(klon))
+      allocate( wo(klon,klev))
+      allocate( clwcon(klon,klev),rnebcon(klon,klev))
+      allocate( heat(klon,klev)    )
+      allocate( heat0(klon,klev)  )
+      allocate( cool(klon,klev)    )
+      allocate( cool0(klon,klev)   )
+      allocate( topsw(klon), toplw(klon), solsw(klon), sollw(klon))
+      allocate( sollwdown(klon)    )
+      allocate( sollwdownclr(klon)  ) 
+      allocate( toplwdown(klon)      )
+      allocate( toplwdownclr(klon)   )
+      allocate( topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon))
+      allocate( albpla(klon))
+      allocate( cape(klon)   )        
+      allocate( pbase(klon)   )     
+      allocate( bbase(klon)    )     
+      allocate( ibas_con(klon), itop_con(klon))
+      allocate( ratqs(klon,klev))
+      allocate( sulfate_pi(klon, klev)) 
+      allocate( paire_ter(klon))
+      allocate(tsumSTD(klon,nlevSTD,nout))
+      allocate(usumSTD(klon,nlevSTD,nout))
+      allocate(vsumSTD(klon,nlevSTD,nout))
+      allocate(wsumSTD(klon,nlevSTD,nout))
+      allocate(phisumSTD(klon,nlevSTD,nout))
+      allocate(qsumSTD(klon,nlevSTD,nout))
+      allocate(rhsumSTD(klon,nlevSTD,nout))
+      allocate(uvsumSTD(klon,nlevSTD,nout))
+      allocate(vqsumSTD(klon,nlevSTD,nout))
+      allocate(vTsumSTD(klon,nlevSTD,nout))
+      allocate(wqsumSTD(klon,nlevSTD,nout))
+      allocate( vphisumSTD(klon,nlevSTD,nout))
+      allocate( wTsumSTD(klon,nlevSTD,nout))
+      allocate( u2sumSTD(klon,nlevSTD,nout))
+      allocate( v2sumSTD(klon,nlevSTD,nout))
+      allocate( T2sumSTD(klon,nlevSTD,nout))
+      allocate( seed_old(klon,napisccp))
+      allocate( pct_ocean(klon,nbregdyn))
+      allocate( rlonPOS(klon))
+      allocate( newsst(klon))
+      allocate( zqasc(klon,klev))
+      allocate( rain_con(klon))
+      allocate( u10m(klon,nbsrf), v10m(klon,nbsrf)) 
+      allocate( topswad(klon), solswad(klon))
+      allocate( topswai(klon), solswai(klon) )
+#ifdef INCA_AER
+#ifdef CPP_COUPLE
+      allocate( topswad_inca(klon), solswad_inca(klon))
+      allocate( topswad0_inca(klon), solswad0_inca(klon))
+      allocate( topswai_inca(klon), solswai_inca(klon))
+      allocate( topsw_inca(klon,9), solsw_inca(klon,9))
+      allocate( topsw0_inca(klon,9), solsw0_inca(klon,9))
+      allocate( tau_inca(klon,klev,9,2))
+      allocate( piz_inca(klon,klev,9,2))
+      allocate( cg_inca(klon,klev,9,2))
+      allocate( ccm(klon,klev,2) )
+#endif
+#endif
+      allocate( clwcon0(klon,klev),rnebcon0(klon,klev))
+      allocate( tau_ae(klon,klev,2), piz_ae(klon,klev,2))
+      allocate( cg_ae(klon,klev,2))
+      allocate( snow_con(klon))
+      allocate( tnondef(klon,nlevSTD,nout)) 
+      allocate( d_u_con(klon,klev),d_v_con(klon,klev))            
+      
+      
+        paire_ter(:)=0.    
+        clwcon(:,:)=0.
+	rnebcon(:,:)=0.
+	ratqs(:,:)=0.
+	sollw(:)=0.
+	ema_work1(:,:)=0.
+	ema_work2(:,:)=0.
+cym Attention pbase pas initialise dans concvl !!!!
+        pbase(:)=0
+	
+	first=.false.
+      endif 
+
+                  
+       modname = 'physiq'
+cIM
+      IF (ip_ebil_phy.ge.1) THEN
+        DO i=1,klon
+          zero_v(i)=0.
+        END DO 
+      END IF 
+      ok_sync=.TRUE.
+      IF (nqmax .LT. 2) THEN
+         abort_message = 'eaux vapeur et liquide sont indispensables'
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      IF (debut) THEN
+         CALL suphec ! initialiser constantes et parametres phys.
+      ENDIF
+
+
+c======================================================================
+      xjour = rjourvrai
+c
+c Si c'est le debut, il faut initialiser plusieurs choses
+c          ********
+c
+       IF (debut) THEN
+C
+!rv
+         u10m(:,:)=0.
+         v10m(:,:)=0.
+         piz_ae(:,:,:)=0.
+         tau_ae(:,:,:)=0.
+         cg_ae(:,:,:)=0.
+         rain_con(:)=0.
+         snow_con(:)=0.
+         bl95_b0=0.
+         bl95_b1=0.
+         topswai(:)=0.
+         topswad(:)=0.
+         solswai(:)=0.
+         solswad(:)=0.
+#ifdef INCA_AER
+#ifdef CPP_COUPLE
+         tau_inca(:,:,:,:) = 0.
+         piz_inca(:,:,:,:) = 0.
+         cg_inca(:,:,:,:)  = 0.
+         ccm(:,:,:)        = 0.
+         topswai_inca(:)   = 0.
+         topswad_inca(:)   = 0.
+         topswad0_inca(:)  = 0.
+         topsw_inca(:,:)   = 0.
+         topsw0_inca(:,:)  = 0.
+         solswai_inca(:)   = 0.
+         solswad_inca(:)   = 0.
+         solswad0_inca(:)  = 0.
+         solsw_inca(:,:)   = 0.
+         solsw0_inca(:,:)  = 0.
+#endif
+#endif
+!rv
+!ACo
+         d_u_con(:,:) = 0.0
+         d_v_con(:,:) = 0.0
+         rnebcon0(:,:) = 0.0
+         clwcon0(:,:) = 0.0
+         rnebcon(:,:) = 0.0
+         clwcon(:,:) = 0.0
+         paire_ter(:) = 0.0
+c        nhistoW(:,:,:,:) = 0.0
+c        histoW(:,:,:,:) = 0.0
+
+cIM      
+         IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0.
+c
+c appel a la lecture du run.def physique
+c
+         call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel,
+     .                  ok_instan, ok_hf,
+     .                  fact_cldcon, facttemps,ok_newmicro,
+cIM  .                  iflag_cldcon,ratqsbas,ratqshaut, if_ebil,
+     .                  iflag_cldcon,ratqsbas,ratqshaut,
+     .                  ok_ade, ok_aie, 
+     .                  bl95_b0, bl95_b1,
+     .                  iflag_thermals,nsplit_thermals)
+
+c
+c
+c Initialiser les compteurs:
+c
+         itap    = 0
+         itaprad = 0
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd
+! plutot que
+! dyn3d
+! Attention : la version precedente n'etait pas tres propre.
+! Il se peut qu'il faille prendre une valeur differente de nbapp_rad
+! pour obtenir le meme resultat.
+         dtime=pdtphys
+         radpas = NINT( 86400./dtime/nbapp_rad)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         CALL phyetat0 ("startphy.nc",dtime,co2_ppm_etat0,solaire_etat0,
+     .       rlat,rlon,pctsrf, ftsol,
+     .       ocean, ok_veget,
+     .       falbe, falblw, rain_fall,snow_fall,
+     .       solsw, sollw,
+     .       radsol,clesphy0,
+     .       zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0,
+     .       t_ancien, q_ancien, ancien_ok, rnebcon, ratqs,clwcon)
+
+       DO i=1,klon
+         IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + 
+     $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
+     $       THEN 
+            WRITE(*,*)
+     $   'physiq apres lecture de restart: pb sous surface au point ',
+     $   i, pctsrf(i, 1 : nbsrf)
+         ENDIF 
+      ENDDO
+
+c
+C on remet le calendrier a zero
+c
+         IF (raz_date .eq. 1) THEN
+           itau_phy = 0
+         ENDIF
+
+cIM cf. AM 081204 BEG
+         PRINT*,'cycle_diurne3 =',cycle_diurne
+cIM cf. AM 081204 END
+c
+         CALL printflag( tabcntr0,radpas,ok_journe,
+     ,                    ok_instan, ok_region )
+c
+         IF (ABS(dtime-pdtphys).GT.0.001) THEN
+            WRITE(lunout,*) 'Pas physique n est pas correct',dtime,
+     .                        pdtphys
+            abort_message='Pas physique n est pas correct '
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlon .NE. klon) THEN
+            WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, 
+     .                      klon
+            abort_message='nlon et klon ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlev .NE. klev) THEN
+            WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev,
+     .                       klev
+            abort_message='nlev et klev ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+c
+         IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN 
+           WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
+           WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
+           abort_message='Nbre d appels au rayonnement insuffisant'
+           call abort_gcm(modname,abort_message,1)
+         ENDIF
+         WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con
+         WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=",
+     .                   ok_cvl
+c
+cKE43
+c Initialisation pour la convection de K.E. (sb):
+         IF (iflag_con.GE.3) THEN
+
+         WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3  "
+         WRITE(lunout,*)
+     .      "On va utiliser le melange convectif des traceurs qui"
+         WRITE(lunout,*)"est calcule dans convect4.3"
+         WRITE(lunout,*)" !!! penser aux logical flags de phytrac"
+
+          DO i = 1, klon
+           ema_cbmf(i) = 0.
+           ema_pcb(i)  = 0.
+           ema_pct(i)  = 0.
+           ema_workcbmf(i) = 0.
+          ENDDO
+cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG
+          DO i = 1, klon
+           ibas_con(i) = 1
+           itop_con(i) = 1
+          ENDDO
+cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END
+
+         ENDIF
+
+c34EK
+         IF (ok_orodr) THEN
+           DO i=1,klon
+             rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+           ENDDO
+           CALL SUGWD(klon,klev,paprs,pplay)
+           DO i=1,klon
+             zuthe(i)=0.
+             zvthe(i)=0.
+             if(zstd(i).gt.10.)then
+               zuthe(i)=(1.-zgam(i))*cos(zthe(i))
+               zvthe(i)=(1.-zgam(i))*sin(zthe(i))
+             endif
+           ENDDO
+         ENDIF
+c
+c
+         lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
+         WRITE(lunout,*)'La frequence de lecture surface est de ', 
+     .                   lmt_pas
+c
+cIM200505        ecrit_mth = NINT(86400./dtime *ecritphy)  ! tous les ecritphy jours
+c        IF (ok_mensuel) THEN
+c        WRITE(lunout,*)'La frequence de sortie mensuelle est de ', 
+c    .                   ecrit_mth
+c        ENDIF
+c        ecrit_day = NINT(86400./dtime *1.0)  ! tous les jours
+c        IF (ok_journe) THEN
+c        WRITE(lunout,*)'La frequence de sortie journaliere est de ',
+c    .                   ecrit_day
+c        ENDIF
+cIM 130904 BEG
+cIM 080205      ecrit_hf = 86400./dtime *0.25  ! toutes les 6h
+cIM 170305      
+c        ecrit_hf = 86400./dtime/12.  ! toutes les 2h
+cIM 230305      
+cIM200505        ecrit_hf = 86400./dtime *0.25  ! toutes les 6h
+c
+cIM200505        ecrit_hf2mth = ecrit_day/ecrit_hf*30
+c
+cIM200505        IF (ok_journe) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie hf est de ',
+cIM200505    .                   ecrit_hf
+cIM200505        ENDIF
+cIM 130904 END
+ccc         ecrit_ins = NINT(86400./dtime *0.5)  ! 2 fois par jour
+ccc         ecrit_ins = NINT(86400./dtime *0.25)  ! 4 fois par jour
+c        ecrit_ins = NINT(86400./dtime/48.)  ! a chaque pas de temps ==> PB. dans time_counter pour 1mois
+c        ecrit_ins = NINT(86400./dtime/12.)  ! toutes les deux heures
+cIM200505        ecrit_ins = NINT(86400./dtime/8.)  ! toutes les trois heures
+cIM200505        IF (ok_instan) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie instant. est de ', 
+cIM200505    .                   ecrit_ins
+cIM200505        ENDIF
+cIM200505        ecrit_reg = NINT(86400./dtime *0.25)  ! 4 fois par jour
+cIM200505        IF (ok_region) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie region est de ', 
+cIM200505    .                   ecrit_reg
+cIM200505        ENDIF
+cIM 030306 BEG
+cIM ecrit_hf2mth = nombre de pas de temps de calcul de hf par mois apres lequel on ecrit
+cIM : ne pas modifier ecrit_hf2mth
+c
+         ecrit_hf2mth = 30*1/ecrit_hf 
+c ecrit_ins en secondes, chaque pas de temps de la physique
+         ecrit_ins = dtime
+cIM on passe les frequences de jours en secondes : ecrit_ins, ecrit_hf, ecrit_day, ecrit_mth, ecrit_tra, ecrit_reg
+         ecrit_hf = ecrit_hf * un_jour
+!IM
+         IF(ecrit_day.LE.1.) THEN
+          ecrit_day = ecrit_day * un_jour !en secondes
+         ENDIF
+!IM
+         ecrit_mth = ecrit_mth * un_jour
+         ecrit_reg = ecrit_reg * un_jour
+         ecrit_tra = ecrit_tra * un_jour
+         ecrit_ISCCP = ecrit_ISCCP * un_jour
+c
+         PRINT*,'physiq ecrit_ hf day mth reg tra ISCCP',ecrit_hf,
+     .   ecrit_day,ecrit_mth,ecrit_reg,ecrit_tra,ecrit_ISCCP
+cIM 030306 END
+
+      capemaxcels = 't_max(X)'
+      t2mincels = 't_min(X)'
+      t2maxcels = 't_max(X)'
+      tinst = 'inst(X)'
+      tave = 'ave(X)'
+cIM cf. AM 081204 BEG
+      write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con
+cIM cf. AM 081204 END
+c
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+
+#ifdef histhf
+#include "ini_histhf.h"
+#endif
+
+#ifdef histday
+#include "ini_histday.h"
+cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+c#include "ini_bilKP_ins.h"
+c#include "ini_bilKP_ave.h"
+#endif
+
+#ifdef histmth
+#include "ini_histmth.h"
+#endif
+
+#ifdef histins
+#include "ini_histins.h"
+#endif
+
+#ifdef histISCCP
+#include "ini_histISCCP.h"
+#endif
+
+#ifdef histmthNMC
+#include "ini_histmthNMC.h"
+#endif
+
+#include "ini_histday_seri.h"
+
+#include "ini_paramLMDZ_phy.h"
+
+#endif
+
+cXXXPB Positionner date0 pour initialisation de ORCHIDEE
+      date0 = zjulian
+C      date0 = day_ini
+      WRITE(*,*) 'physiq date0 : ',date0
+c
+c
+c
+c Prescrire l'ozone dans l'atmosphere
+c
+c
+cc         DO i = 1, klon
+cc         DO k = 1, klev
+cc            CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
+cc         ENDDO
+cc         ENDDO
+c
+#ifdef INCA
+           call VTe(VTphysiq)
+	   call VTb(VTinca)
+           iii = MOD(NINT(xjour),360)
+           calday = FLOAT(iii) + gmtime
+           WRITE(lunout,*) 'initial time ', xjour, calday
+#ifdef INCAINFO
+           WRITE(lunout,*) 'Appel CHEMINI ...'
+#endif
+           CALL chemini( 
+     $                   rg,
+     $                   ra,
+     $                   airephy,
+     $                   rlat,
+     $                   rlon,
+     $                   presnivs,
+     $                   calday,
+     $                   klon,
+     $                   nqmax,
+     $                   pdtphys,
+     $                   annee_ref,
+     $                   day_ini)
+#ifdef INCAINFO
+           WRITE(lunout,*) 'OK.'
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+c
+      ENDIF
+c
+c   ****************     Fin  de   IF ( debut  )   ***************
+c
+c
+c Mettre a zero des variables de sortie (pour securite)
+c
+      DO i = 1, klon
+         d_ps(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO iq = 1, nqmax
+      DO k = 1, klev
+      DO i = 1, klon
+         d_qx(i,k,iq) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+      da(:,:)=0.
+      mp(:,:)=0.
+      phi(:,:,:)=0.
+c
+c Ne pas affecter les valeurs entrees de u, v, h, et q
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k)  = t(i,k)
+         u_seri(i,k)  = u(i,k)
+         v_seri(i,k)  = v(i,k)
+         q_seri(i,k)  = qx(i,k,ivap)
+         ql_seri(i,k) = qx(i,k,iliq)
+         qs_seri(i,k) = 0.
+      ENDDO
+      ENDDO
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         tr_seri(i,k,iq-2) = qx(i,k,iq)
+      ENDDO
+      ENDDO
+      ENDDO
+      ELSE
+      DO k = 1, klev
+      DO i = 1, klon
+         tr_seri(i,k,1) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+        ztsol(i) = 0.
+      ENDDO
+      DO nsrf = 1, nbsrf
+        DO i = 1, klon
+          ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+        ENDDO
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after dynamic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol+d_h_vcol_phy, d_qt, 0.
+     s      , fs_bound, fq_bound )
+      END IF 
+
+c Diagnostiquer la tendance dynamique
+c
+      IF (ancien_ok) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime
+            d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime
+         ENDDO
+         ENDDO
+      ELSE
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = 0.0
+            d_q_dyn(i,k) = 0.0
+         ENDDO
+         ENDDO
+         ancien_ok = .TRUE.
+      ENDIF
+c
+c Ajouter le geopotentiel du sol:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zphi(i,k) = pphi(i,k) + pphis(i)
+      ENDDO
+      ENDDO
+c
+c Verifier les temperatures
+c
+cIM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+c
+       PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+cIM END
+c
+      CALL hgardfou(t_seri,ftsol,'debutphy')
+c
+cIM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+c
+       PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+cIM END
+c
+c Incrementer le compteur de la physique
+c
+      itap   = itap + 1
+      julien = MOD(NINT(xjour),360)
+      if (julien .eq. 0) julien = 360
+c
+c Mettre en action les conditions aux limites (albedo, sst, etc.).
+c Prescrire l'ozone et calculer l'albedo sur l'ocean.
+c
+      IF (MOD(itap-1,lmt_pas) .EQ. 0) THEN
+         WRITE(lunout,*)' PHYS cond  julien ',julien
+         CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
+      ENDIF
+c
+c Re-evaporer l'eau liquide nuageuse
+c
+      DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+c        zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+         zb = MAX(0.0,ql_seri(i,k))
+         za = - MAX(0.0,ql_seri(i,k))
+     .                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         t_seri(i,k) = t_seri(i,k) + za
+         q_seri(i,k) = q_seri(i,k) + zb
+         ql_seri(i,k) = 0.0
+         d_t_eva(i,k) = za
+         d_q_eva(i,k) = zb
+      ENDDO
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after reevap'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      END IF 
+
+c
+C calculs necessaires au calcul de l'albedo dans l'interface
+c
+      CALL orbite(FLOAT(julien),zlongi,dist)
+      IF (cycle_diurne) THEN
+        zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
+        CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
+      ELSE
+        rmu0 = -999.999
+      ENDIF
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Appel au pbl_surface : Planetary Boudary Layer et Surface
+c Cela implique tous les interactions des sous-surfaces et la partie diffusion 
+c turbulent du couche limit. 
+c 
+c Certains varibales de sorties de pbl_surface sont utiliser que pour 
+c ecriture des fihiers hist_XXXX.nc, ces sont :
+c   qsol,      zq2m,      s_pblh,  s_lcl,
+c   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+c   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+c   zxrugs,    zu10m,     zv10m,   fder,
+c   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+c   frugs,     agesno,    fsollw,  fsolsw,
+c   d_ts,      fevap,     fluxlat, t2m,
+c   wfbils,    wfbilo,    fluxt,   fluxu, fluxv,
+c
+c Certains ne sont pas utiliser du tout : 
+c   dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
+c
+      CALL pbl_surface( 
+     e     dtime,     date0,     itap,    julien,
+     e     debut,     lafin,
+     e     rlon,      rlat,      rugoro,  rmu0,     
+     e     rain_fall, snow_fall, solsw,   sollw,    
+     e     t_seri,    q_seri,    u_seri,  v_seri,   
+     e     pplay,     paprs,     pctsrf,            
+     +     ftsol,     falbe,     falblw,  u10m,   v10m,
+     s     sollwdown, cdragh,    cdragm,  yu1,    yv1,
+     s     albsol,    albsollw,  sens,    evap,  
+     s     zxtsol,    zxfluxlat, zt2m,    qsat2m, 
+     s     d_t_vdf,   d_q_vdf,   d_u_vdf, d_v_vdf,
+     s     ycoefh,    pctsrf_new,                
+     d     qsol,      zq2m,      s_pblh,  s_lcl,
+     d     s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+     d     s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+     d     zxrugs,    zu10m,     zv10m,   fder,
+     d     zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+     d     frugs,     agesno,    fsollw,  fsolsw,
+     d     d_ts,      fevap,     fluxlat, t2m,
+     d     wfbils,    wfbilo,    fluxt,   fluxu,  fluxv,
+     -     dsens,     devap,     zxsnow,
+     -     zxfluxt,   zxfluxq,   q2m,     fluxq )
+c
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      pctsrf(:,:) = pctsrf_new(:,:)
+      
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_vdf(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_vdf(i,k)
+         u_seri(i,k) = u_seri(i,k) + d_u_vdf(i,k)
+         v_seri(i,k) = v_seri(i,k) + d_v_vdf(i,k)
+      ENDDO
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after surface_main'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, sens
+     e      , evap  , zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+
+c
+c Appeler la convection (au choix)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         conv_q(i,k) = d_q_dyn(i,k) 
+     .               + d_q_vdf(i,k)/dtime
+         conv_t(i,k) = d_t_dyn(i,k) 
+     .               + d_t_vdf(i,k)/dtime
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*) "avantcon=", za
+      ENDIF
+      zx_ajustq = .FALSE.
+      IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
+      IF (zx_ajustq) THEN
+         DO i = 1, klon
+            z_avant(i) = 0.0
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+            z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k))
+     .                        *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDDO
+         ENDDO
+      ENDIF
+      IF (iflag_con.EQ.1) THEN
+          stop'reactiver le call conlmd dans physiq.F'
+c     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
+c    .             d_t_con, d_q_con,
+c    .             rain_con, snow_con, ibas_con, itop_con)
+      ELSE IF (iflag_con.EQ.2) THEN
+      CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
+     e            conv_t, conv_q, -evap, omega,
+     s            d_t_con, d_q_con, rain_con, snow_con,
+     s            pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s            kcbot, kctop, kdtop, pmflxr, pmflxs)
+      WHERE (rain_con < 0.) rain_con = 0.
+      WHERE (snow_con < 0.) snow_con = 0.
+      DO i = 1, klon
+         ibas_con(i) = klev+1 - kcbot(i)
+         itop_con(i) = klev+1 - kctop(i)
+      ENDDO
+      ELSE IF (iflag_con.GE.3) THEN
+c nb of tracers for the KE convection:
+c MAF la partie traceurs est faite dans phytrac
+c on met ntra=1 pour limiter les appels mais on peut
+c supprimer les calculs / ftra.
+              ntra = 1
+c sb, oct02:
+c Schema de convection modularise et vectorise:
+c (driver commun aux versions 3 et 4)
+c
+          IF (ok_cvl) THEN ! new driver for convectL
+
+          CALL concvl (iflag_con,
+     .        dtime,paprs,pplay,t_seri,q_seri,
+     .        u_seri,v_seri,tr_seri,ntra,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,
+     .        Ma,cape,tvp,iflagctrl,
+     .        pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd,
+     .        pmflxr,pmflxs,
+     .        da,phi,mp)
+
+cIM cf. FH
+              clwcon0=qcondc
+              pmfu(:,:)=upwd(:,:)+dnwd(:,:)
+
+          ELSE ! ok_cvl
+c MAF conema3 ne contient pas les traceurs
+          CALL conema3 (dtime,
+     .        paprs,pplay,t_seri,q_seri,
+     .        u_seri,v_seri,tr_seri,ntra,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,bas,top,
+     .        Ma,cape,tvp,rflag,
+     .        pbase
+     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr
+     .        ,clwcon0)
+
+          ENDIF ! ok_cvl
+
+c
+c Correction precip
+          rain_con = rain_con * cvl_corr
+          snow_con = snow_con * cvl_corr
+c
+
+           IF (.NOT. ok_gust) THEN
+           do i = 1, klon
+            wd(i)=0.0
+           enddo
+           ENDIF
+
+c =================================================================== c
+c Calcul des proprietes des nuages convectifs
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+c   calcul des proprietes des nuages convectifs
+             clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
+             call clouds_gno
+     s       (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
+
+c =================================================================== c
+
+          DO i = 1, klon
+            ema_pcb(i)  = pbase(i)
+          ENDDO
+          DO i = 1, klon
+            ema_pct(i)  = paprs(i,itop_con(i))
+          ENDDO
+          DO i = 1, klon
+            ema_cbmf(i) = ema_workcbmf(i)
+          ENDDO      
+      ELSE
+          WRITE(lunout,*) "iflag_con non-prevu", iflag_con
+          CALL abort
+      ENDIF
+
+c     CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
+c    .              d_u_con, d_v_con)
+
+      DO k = 1, klev
+        DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_con(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_con(i,k)
+         u_seri(i,k) = u_seri(i,k) + d_u_con(i,k)
+         v_seri(i,k) = v_seri(i,k) + d_v_con(i,k)
+        ENDDO
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after convect'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_con, snow_con, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+C
+      IF (check) THEN
+          za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+          WRITE(lunout,*)"aprescon=", za
+          zx_t = 0.0
+          za = 0.0
+          DO i = 1, klon
+            za = za + airephy(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_con(i)+
+     .                   snow_con(i))*airephy(i)/FLOAT(klon)
+          ENDDO
+          zx_t = zx_t/za*dtime
+          WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+      IF (zx_ajustq) THEN
+          DO i = 1, klon
+            z_apres(i) = 0.0
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k))
+     .            *(paprs(i,k)-paprs(i,k+1))/RG
+            ENDDO
+          ENDDO
+          DO i = 1, klon
+            z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime)
+     .          /z_apres(i)
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              IF (z_factor(i).GT.(1.0+1.0E-08) .OR.
+     .            z_factor(i).LT.(1.0-1.0E-08)) THEN
+                  q_seri(i,k) = q_seri(i,k) * z_factor(i)
+              ENDIF
+            ENDDO
+          ENDDO
+      ENDIF
+      zx_ajustq=.FALSE.
+c
+c===================================================================
+c Convection seche (thermiques ou ajustement)
+c===================================================================
+c
+      d_t_ajs(:,:)=0.
+      d_u_ajs(:,:)=0.
+      d_v_ajs(:,:)=0.
+      d_q_ajs(:,:)=0.
+      fm_therm(:,:)=0.
+      entr_therm(:,:)=0.
+c
+      IF(prt_level>9)WRITE(lunout,*)
+     .    'AVANT LA CONVECTION SECHE , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+      if(iflag_thermals.lt.0) then
+c  Rien
+c  ====
+         IF(prt_level>9)WRITE(lunout,*)'pas de convection'
+      else if(iflag_thermals.eq.0) then
+
+c  Ajustement sec
+c  ==============
+         IF(prt_level>9)WRITE(lunout,*)'ajsec'
+         CALL ajsec(paprs, pplay, t_seri,q_seri, d_t_ajs, d_q_ajs)
+         t_seri(:,:) = t_seri(:,:) + d_t_ajs(:,:)
+         q_seri(:,:) = q_seri(:,:) + d_q_ajs(:,:)
+      else
+c  Thermiques
+c  ==========
+         IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+         call calltherm(pdtphys
+     s      ,pplay,paprs,pphi
+     s      ,u_seri,v_seri,t_seri,q_seri
+     s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
+     s      ,fm_therm,entr_therm)
+      endif
+c
+c===================================================================
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after dry_adjust'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+
+
+c-------------------------------------------------------------------------
+c  Caclul des ratqs
+c-------------------------------------------------------------------------
+
+c      print*,'calcul des ratqs'
+c   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
+c   ----------------
+c   on ecrase le tableau ratqsc calcule par clouds_gno
+      if (iflag_cldcon.eq.1) then
+         do k=1,klev
+         do i=1,klon
+            if(ptconv(i,k)) then
+              ratqsc(i,k)=ratqsbas
+     s        +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+            else
+               ratqsc(i,k)=0.
+            endif
+         enddo
+         enddo
+      endif
+
+c   ratqs stables
+c   -------------
+      do k=1,klev
+cIM RAJOUT boucle do=i
+       do i=1, klon
+cIM         ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas)*
+cIM     s   min((paprs(:,1)-pplay(:,k))/(paprs(:,1)-30000.),1.) 
+         ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s   min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) 
+cIM      print*,' IMratqs STABLE i, k',i,k,ratqss(i,k)
+       enddo 
+      enddo
+
+
+c  ratqs final
+c  -----------
+      if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2) then
+c   les ratqs sont une conbinaison de ratqss et ratqsc
+c   ratqs final
+c   1e4 (en gros 3 heures), en dur pour le moment, est le temps de
+c   relaxation des ratqs
+c         facttemps=exp(-pdtphys/1.e4)
+         facteur=exp(-pdtphys*facttemps)
+         ratqs(:,:)=max(ratqs(:,:)*facteur,ratqss(:,:))
+         ratqs(:,:)=max(ratqs(:,:),ratqsc(:,:))
+c         print*,'calcul des ratqs fini'
+      else
+c   on ne prend que le ratqs stable pour fisrtilp
+         ratqs(:,:)=ratqss(:,:)
+      endif
+
+
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c-------------------------------------------------------------------------
+      CALL fisrtilp(dtime,paprs,pplay,
+     .           t_seri, q_seri,ptconv,ratqs,
+     .           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq,
+     .           rain_lsc, snow_lsc,
+     .           pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     .           frac_impa, frac_nucl,
+     .           prfl, psfl, rhcl)
+
+      WHERE (rain_lsc < 0) rain_lsc = 0.
+      WHERE (snow_lsc < 0) snow_lsc = 0.
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_lsc(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_lsc(i,k)
+         ql_seri(i,k) = ql_seri(i,k) + d_ql_lsc(i,k)
+         cldfra(i,k) = rneb(i,k)
+         IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*)"apresilp=", za
+         zx_t = 0.0
+         za = 0.0
+         DO i = 1, klon
+            za = za + airephy(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_lsc(i)
+     .                  + snow_lsc(i))*airephy(i)/FLOAT(klon)
+        ENDDO
+         zx_t = zx_t/za*dtime
+         WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after fisrt'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_lsc, snow_lsc, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+c
+c-------------------------------------------------------------------
+c  PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
+c-------------------------------------------------------------------
+
+c 1. NUAGES CONVECTIFS
+c
+cIM cf FH
+c     IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke
+       IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke
+       snow_tiedtke=0.
+c     print*,'avant calcul de la pseudo precip '
+c     print*,'iflag_cldcon',iflag_cldcon
+       if (iflag_cldcon.eq.-1) then
+          rain_tiedtke=rain_con
+       else
+c       print*,'calcul de la pseudo precip '
+          rain_tiedtke=0.
+c         print*,'calcul de la pseudo precip 0'
+          do k=1,klev
+          do i=1,klon
+             if (d_q_con(i,k).lt.0.) then
+                rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys
+     s         *(paprs(i,k)-paprs(i,k+1))/rg
+             endif
+          enddo
+          enddo
+       endif
+c
+c     call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ')
+c
+
+c Nuages diagnostiques pour Tiedtke
+      CALL diagcld1(paprs,pplay,
+cIM cf FH  .             rain_con,snow_con,ibas_con,itop_con,
+     .             rain_tiedtke,snow_tiedtke,ibas_con,itop_con,
+     .             diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+
+      ELSE IF (iflag_cldcon.eq.3) THEN
+c  On prend pour les nuages convectifs le max du calcul de la
+c  convection et du calcul du pas de temps precedent diminue d'un facteur
+c  facttemps
+c      facttemps=pdtphys/1.e4
+      facteur = pdtphys *facttemps
+      do k=1,klev
+         do i=1,klon
+            rnebcon(i,k)=rnebcon(i,k)*facteur
+            if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k))
+     s      then
+                rnebcon(i,k)=rnebcon0(i,k)
+                clwcon(i,k)=clwcon0(i,k)
+            endif
+         enddo
+      enddo
+
+c
+cjq - introduce the aerosol direct and first indirect radiative forcings
+cjq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
+      IF (ok_ade.OR.ok_aie) THEN
+#if defined(CPP_COUPLE) && !defined(INCA_AER)
+         ! Get sulfate aerosol distribution
+         CALL readsulfate(rjourvrai, debut, sulfate)
+         CALL readsulfate_preind(rjourvrai, debut, sulfate_pi)
+
+         ! Calculate aerosol optical properties (Olivier Boucher)
+         CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl,
+     .        tau_ae, piz_ae, cg_ae, aerindex)
+#endif
+#if !defined(CPP_COUPLE)
+         ! Get sulfate aerosol distribution
+         CALL readsulfate(rjourvrai, debut, sulfate)
+         CALL readsulfate_preind(rjourvrai, debut, sulfate_pi)
+
+         ! Calculate aerosol optical properties (Olivier Boucher)
+         CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl,
+     .        tau_ae, piz_ae, cg_ae, aerindex)
+#endif
+cym
+      ELSE
+        tau_ae(:,:,:)=0.0
+	piz_ae(:,:,:)=0.0
+	cg_ae(:,:,:)=0.0
+cym     
+      ENDIF
+
+c
+cIM calcul nuages par le simulateur ISCCP
+c
+#ifdef histISCCP
+      IF (ok_isccp) THEN
+cIM appel simulateur toutes les  NINT(freq_ISCCP/dtime) heures
+       IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN
+#include "calcul_simulISCCP.h"
+       ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime))
+      ENDIF !ok_isccp
+#endif
+
+c   On prend la somme des fractions nuageuses et des contenus en eau
+      cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+      cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
+
+      ENDIF
+
+c
+c 2. NUAGES STARTIFORMES
+c
+      IF (ok_stratus) THEN
+      CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Precipitation totale
+c
+      DO i = 1, klon
+         rain_fall(i) = rain_con(i) + rain_lsc(i)
+         snow_fall(i) = snow_con(i) + snow_lsc(i)
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit="after diagcld"
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c Calculer l'humidite relative pour diagnostique
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zx_rh(i,k) = q_seri(i,k)/zx_qs
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+cIM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 
+c   equivalente a 2m (tpote) pour diagnostique
+c
+      DO i = 1, klon
+       tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA
+       IF (thermcep) THEN
+        IF(zt2m(i).LT.RTT) then
+	 Lheat=RLSTT
+	ELSE
+	 Lheat=RLVTT
+        ENDIF
+       ELSE
+        IF (zt2m(i).LT.RTT) THEN
+         Lheat=RLSTT
+        ELSE
+	 Lheat=RLVTT
+        ENDIF
+       ENDIF
+       tpote(i) = tpot(i)*     
+     . EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i)))
+      ENDDO
+
+
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+           calday = FLOAT(julien) + gmtime
+
+#ifdef INCA_AER
+      call AEROSOL_METEO_CALC(calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs
+     &   ,prfl,psfl,pctsrf,airephy,xjour,rlat,rlon,u10m,v10m)
+#endif
+
+#ifdef INCAINFO
+           WRITE(lunout,*)'Appel CHEMHOOK_BEGIN ...'
+#endif
+
+           zxsnow_dummy(:) = 0.0
+
+           CALL chemhook_begin (calday,
+#if defined(INCA) && !defined(INCA_CH4) && !defined(INCA_NMHC) && !defined(INCA_AER)
+     $                          julien,
+     $                          gmtime,
+#endif
+     $                          pctsrf(1,1),
+     $                          rlat,
+     $                          rlon,
+     $                          airephy,
+     $                          paprs,
+     $                          pplay,
+     $                          ycoefh,
+     $                          pphi,
+     $                          t_seri,
+     $                          u,
+     $                          v,
+     $                          wo,
+     $                          q_seri,
+     $                          zxtsol,
+     $                          zxsnow_dummy,
+     $                          solsw,
+     $                          albsol,
+     $                          rain_fall,
+     $                          snow_fall,
+     $                          itop_con,
+     $                          ibas_con,
+     $                          cldfra,
+     $                          iim,
+     $                          jjm,
+#ifdef INCA_AER
+     $                          tr_seri,
+     $                          ftsol,
+     $                          paprs,
+     $                          cdragh,
+     $                          cdragm,
+     $                          pctsrf,
+     $				pdtphys,
+     $				itap)
+#else
+     $                          tr_seri)     
+#endif        
+
+
+#ifdef INCAINFO
+           WRITE(lunout,*)'OK.'
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+c     
+c Calculer les parametres optiques des nuages et quelques
+c parametres pour diagnostiques:
+c
+      if (ok_newmicro) then
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq,
+     .            flwp, fiwp, flwc, fiwc,
+     e            ok_aie,
+#if defined(CPP_COUPLE) && defined(INCA_AER)  
+     e            ccm(:,:,1), ccm(:,:,2),
+#else
+     e            sulfate, sulfate_pi,
+#endif
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+      else
+      CALL nuage (paprs, pplay,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+      
+      endif
+c
+c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
+c
+      IF (MOD(itaprad,radpas).EQ.0) THEN
+
+      DO i = 1, klon
+         albsol(i) = falbe(i,is_oce) * pctsrf(i,is_oce)
+     .             + falbe(i,is_lic) * pctsrf(i,is_lic)
+     .             + falbe(i,is_ter) * pctsrf(i,is_ter)
+     .             + falbe(i,is_sic) * pctsrf(i,is_sic)
+         albsollw(i) = falblw(i,is_oce) * pctsrf(i,is_oce)
+     .               + falblw(i,is_lic) * pctsrf(i,is_lic)
+     .               + falblw(i,is_ter) * pctsrf(i,is_ter)
+     .               + falblw(i,is_sic) * pctsrf(i,is_sic)
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+
+#if defined(CPP_COUPLE) && defined(INCA_AER)
+      CALL radlwsw_inca ! nouveau rayonnement (compatible Arpege-IFS)
+     e            (kdlon,kflev,dist, rmu0, fract, 
+     e             paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
+     e             wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             lwdn0, lwdn, lwup0, lwup, 
+     s             swdn0, swdn, swup0, swup,
+     e             ok_ade, ok_aie, ! new for aerosol radiative effects
+     e             tau_inca, piz_inca, cg_inca, ! ="=
+     s             topswad_inca, solswad_inca, ! ="=
+     s             topswad0_inca, solswad0_inca, ! ="=
+     s             topsw_inca, topsw0_inca,
+     s             solsw_inca, solsw0_inca,
+     e             cldtaupi, ! ="=
+     s             topswai_inca, solswai_inca) ! ="=
+#else
+      CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS)
+     e            (dist, rmu0, fract, 
+     e             paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
+     e             wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             lwdn0, lwdn, lwup0, lwup, 
+     s             swdn0, swdn, swup0, swup,
+     e             ok_ade, ok_aie, ! new for aerosol radiative effects
+     e             tau_ae, piz_ae, cg_ae, ! ="=
+     s             topswad, solswad, ! ="=
+     e             cldtaupi, ! ="=
+     s             topswai, solswai) ! ="=
+#endif
+      itaprad = 0
+      ENDIF
+      itaprad = itaprad + 1
+c
+c Ajouter la tendance des rayonnements (tous les pas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k)
+     .               + (heat(i,k)-cool(i,k)) * dtime/86400.
+      ENDDO
+      ENDDO
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+ 
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after rad'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , topsw, toplw, solsw, sollw, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+c
+c
+c Calculer l'hydrologie de la surface
+c
+c      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
+c     .            agesno, ftsol,fqsurf,fsnow, ruis)
+c
+
+c
+c Calculer le bilan du sol et la derive de temperature (couplage)
+c
+      DO i = 1, klon
+c         bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
+c a la demande de JLD
+         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
+      ENDDO
+c
+cmoddeblott(jan95)
+c Appeler le programme de parametrisation de l'orographie
+c a l'echelle sous-maille:
+c
+      IF (ok_orodr) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+c        IF ((zstd(i).gt.10.0)) THEN
+        IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL drag_noro(klon,klev,dtime,paprs,pplay,
+     e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,idx,itest,
+     e                   t_seri, u_seri, v_seri,
+cIM 141004    s                   zulow, zvlow, zustr, zvstr,
+     s                   zulow, zvlow, zustrdr, zvstrdr,
+     s                   d_t_oro, d_u_oro, d_v_oro)
+c
+c  ajout des tendances
+        DO k = 1, klev
+        DO i = 1, klon
+           t_seri(i,k) = t_seri(i,k) + d_t_oro(i,k)
+           u_seri(i,k) = u_seri(i,k) + d_u_oro(i,k)
+           v_seri(i,k) = v_seri(i,k) + d_v_oro(i,k)
+        ENDDO
+        ENDDO
+c
+      ENDIF ! fin de test sur ok_orodr
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+      IF (ok_orolf) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+        IF ((zpic(i)-zmea(i)).GT.100.) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL lift_noro(klon,klev,dtime,paprs,pplay,
+     e                   rlat,zmea,zstd,zpic,
+     e                   itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustrli, zvstrli,
+     s                   d_t_lif, d_u_lif, d_v_lif)
+c
+c  ajout des tendances
+        DO k = 1, klev
+        DO i = 1, klon
+           t_seri(i,k) = t_seri(i,k) + d_t_lif(i,k)
+           u_seri(i,k) = u_seri(i,k) + d_u_lif(i,k)
+           v_seri(i,k) = v_seri(i,k) + d_v_lif(i,k)
+        ENDDO
+        ENDDO
+c
+      ENDIF ! fin de test sur ok_orolf
+c
+cIM cf. FLott BEG
+C STRESS NECESSAIRES: TOUTE LA PHYSIQUE
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO i = 1, klon
+        zustrph(i)=0.
+        zvstrph(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+       zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime*
+     c            (paprs(i,k)-paprs(i,k+1))/rg
+       zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime*
+     c            (paprs(i,k)-paprs(i,k+1))/rg
+      ENDDO
+      ENDDO
+c
+cIM calcul composantes axiales du moment angulaire et couple des montagnes
+c
+      IF (is_sequential) THEN
+      
+        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+     C                 ra,rg,romega,
+     C                 rlat,rlon,pphis,
+     C                 zustrdr,zustrli,zustrph,
+     C                 zvstrdr,zvstrli,zvstrph,
+     C                 paprs,u,v,
+     C                 aam, torsfc)
+       ENDIF
+cIM cf. FLott END
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after orography'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c
+cAA
+cAA Installation de l'interface online-offline pour traceurs
+cAA
+c====================================================================
+c   Calcul  des tendances traceurs
+c====================================================================
+C
+      call phytrac (     rnpb,
+     I                   itap, 
+     I                   julien, 
+     I                   gmtime,
+     I                   debut,
+     I                   lafin,
+     I                   nqmax-2,
+     I                   nlon,
+     I                   nlev,
+     I                   dtime,
+     I                   u,
+     I                   v,
+     I                   t,
+     I                   paprs,
+     I                   pplay,
+     I                   pmfu, 
+     I                   pmfd, 
+     I                   pen_u, 
+     I                   pde_u, 
+     I                   pen_d, 
+     I                   pde_d,
+     I                   ycoefh,
+     I                   fm_therm,
+     I                   entr_therm,
+     I                   yu1,
+     I                   yv1,
+     I                   ftsol,
+     I                   pctsrf,
+     I                   rlat,
+     I                   frac_impa, 
+     I                   frac_nucl,
+     I                   rlon,
+     I                   presnivs,
+     I                   pphis,
+     I                   pphi,
+     I                   albsol,
+     I                   qx(1,1,1), 
+     I                   rhcl,
+     I                   cldfra, 
+     I                   rneb, 
+     I                   diafra, 
+     I                   cldliq, 
+     I                   itop_con,
+     I                   ibas_con,
+     I                   pmflxr,
+     I                   pmflxs,
+     I                   prfl,
+     I                   psfl,
+     I                   da,
+     I                   phi,
+     I                   mp,
+     I                   upwd,
+     I                   dnwd,
+#ifdef INCA
+     I                   flxmass_w,
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+     I                   tau_inca, 
+     I                   piz_inca, 
+     I                   cg_inca,
+     I                   ccm,
+     I                   rfname,
+#endif
+#endif
+     O                   tr_seri)
+
+      IF (offline) THEN
+
+         print*,'Attention on met a 0 les thermiques pour phystoke'
+	 call phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   fm_therm,entr_therm,
+     I                   ycoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa, frac_nucl,
+     I                   pphis,airephy,dtime,itap)
+
+
+      ENDIF
+
+c
+c Calculer le transport de l'eau et de l'energie (diagnostique)
+c
+      CALL transp (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve, vq, ue, uq)
+c
+cIM global posePB BEG
+      IF(1.EQ.0) THEN
+c
+      CALL transp_lay (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve_lay, vq_lay, ue_lay, uq_lay)
+c
+      ENDIF !(1.EQ.0) THEN
+cIM global posePB END
+c Accumuler les variables a stocker dans les fichiers histoire:
+c
+c+jld ec_conser
+      DO k = 1, klev
+      DO i = 1, klon
+        ZRCPD = RCPD*(1.0+RVTMP2*q_seri(i,k))
+        d_t_ec(i,k)=0.5/ZRCPD
+     $      *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2)
+        t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k)
+        d_t_ec(i,k) = d_t_ec(i,k)/dtime
+       END DO 
+      END DO 
+c-jld ec_conser
+cIM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after physic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , topsw, toplw, solsw, sollw, sens
+     e      , evap, rain_fall, snow_fall, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      d_h_vcol_phy=d_h_vcol
+C
+      END IF 
+C
+c=======================================================================
+c   SORTIES
+c=======================================================================
+
+cIM Interpolation sur les niveaux de pression du NMC
+c   -------------------------------------------------
+c
+#include "calcul_STDlev.h"
+c
+c slp sea level pressure
+      slp(:) = paprs(:,1)*exp(pphis(:)/(RD*t_seri(:,1)))
+c
+ccc prw = eau precipitable
+      DO i = 1, klon
+       prw(i) = 0.
+       DO k = 1, klev
+        prw(i) = prw(i) +
+     .           q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+       ENDDO
+      ENDDO
+c
+cIM initialisation + calculs divers diag AMIP2
+c
+#include "calcul_divers.h"
+c
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+#ifdef INCAINFO
+           WRITE(lunout,*)'Appel CHEMHOOK_END ...'
+#endif
+           CALL chemhook_end (calday,
+     $                        dtime,
+     $                        pplay,
+     $                        t_seri,
+     $                        tr_seri,
+     $                        nbtr,
+     $                        paprs,
+     $                        q_seri,
+     $                        annee_ref,
+     $                        day_ini,
+     $                        airephy,
+#ifdef INCA_AER
+     $                        xjour,
+     $                        pphi,
+     $                        pphis,
+     $                        zx_rh)
+#else
+     $                        xjour)
+#endif
+#ifdef INCAINFO
+           WRITE(lunout,*)'OK.'
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+
+c=============================================================
+c
+c Convertir les incrementations en tendances
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
+         d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
+         d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
+         d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
+         d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
+      ENDDO
+      ENDDO
+c
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDIF
+c
+cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+cIM global posePB#include "write_bilKP_ins.h"
+cIM global posePB#include "write_bilKP_ave.h"
+c
+c Sauvegarder les valeurs de t et q a la fin de la physique:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_ancien(i,k) = t_seri(i,k)
+         q_ancien(i,k) = q_seri(i,k)
+      ENDDO
+      ENDDO
+c
+c 22.03.04 BEG
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+#ifdef CPP_IOIPSL
+ 
+c Recupere des varibles calcule dans differents modules
+c pour ecriture dans histxxx.nc 
+
+      ! Get some variables from module mod_fonte_neige
+      CALL fonte_neige_get_vars(pctsrf, 
+     .     zxfqcalving, zxfqfonte, zxffonte)
+
+      IF (ocean == 'slab') THEN
+         ! Get some variables from module oceanslab
+         CALL ocean_slab_get_vars(tslab, seaice, fluxo, fluxg)
+      ELSEIF (ocean == 'couple') THEN
+         ! Get some variables from module oceancpl
+         CALL ocean_cpl_get_vars(fluxo, fluxg)
+      ELSE 
+         ! Get some variables from module oceanforced
+         CALL ocean_forced_get_vars(fluxo, fluxg)
+      ENDIF
+
+#ifdef histhf
+#include "write_histhf.h"
+#endif
+
+#ifdef histday
+#include "write_histday.h"
+#endif
+
+#ifdef histmth
+#include "write_histmth.h"
+#endif
+
+#ifdef histins
+#include "write_histins.h"
+#endif
+
+#ifdef histISCCP
+#include "write_histISCCP.h"
+#endif
+
+#ifdef histmthNMC
+#include "write_histmthNMC.h"
+#endif
+
+#include "write_histday_seri.h"
+
+#include "write_paramLMDZ_phy.h"
+
+#endif
+
+c 22.03.04 END
+c
+c====================================================================
+c Si c'est la fin, il faut conserver l'etat de redemarrage
+c====================================================================
+c
+      
+
+      IF (lafin) THEN
+         itau_phy = itau_phy + itap
+         CALL phyredem ("restartphy.nc",dtime,radpas,ocean,
+     .      rlat, rlon, pctsrf, ftsol,
+     .      falbe,falblw, rain_fall, 
+     .      snow_fall,
+     .      solsw, sollw,
+     .      radsol,
+     .      zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,
+     .      t_ancien, q_ancien, rnebcon, ratqs, clwcon)
+      ENDIF
+      
+
+      RETURN
+      END
+      FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
+      IMPLICIT none
+c
+c Calculer et imprimer l'eau totale. A utiliser pour verifier
+c la conservation de l'eau
+c
+#include "YOMCST.h"
+      INTEGER klon,klev
+      REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
+      REAL aire(klon)
+      REAL qtotal, zx, qcheck
+      INTEGER i, k
+c
+      zx = 0.0
+      DO i = 1, klon
+         zx = zx + aire(i)
+      ENDDO
+      qtotal = 0.0
+      DO k = 1, klev
+      DO i = 1, klon
+         qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i)
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+      ENDDO
+      ENDDO
+c
+      qcheck = qtotal/zx
+c
+      RETURN
+      END
+      SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+      IMPLICIT none
+c
+c Tranformer une variable de la grille physique a
+c la grille d'ecriture
+c
+      INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
+c
+      INTEGER i, n, ig
+c
+      jjm = jjmp1 - 1
+      DO n = 1, nfield
+         DO i=1,iim
+            ecrit(i,n) = fi(1,n)
+            ecrit(i+jjm*iim,n) = fi(nlon,n)
+         ENDDO
+         DO ig = 1, nlon - 2
+           ecrit(iim+ig,n) = fi(1+ig,n)
+         ENDDO
+      ENDDO
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phystokenc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phystokenc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phystokenc.F	(revision 984)
@@ -0,0 +1,430 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   pfm_therm,pentr_therm,
+     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa,frac_nucl,
+     I                   pphis,paire,dtime,itap)
+      USE ioipsl
+      USE dimphy
+      USE iophy
+      IMPLICIT none
+
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+
+c======================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "tracstoke.h"
+#include "indicesol.h"
+#include "control.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon ! nombre de points horizontaux
+      integer nlev ! nombre de couches verticales
+      real pdtphys ! pas d'integration pour la physique (seconde)
+c
+      integer physid, itap
+      save physid
+c$OMP THREADPRIVATE(physid)
+      integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
+
+c   convection:
+c   -----------
+c
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+      real pt(klon,klev)
+      REAL,allocatable,save :: t(:,:)
+c$OMP THREADPRIVATE(t)
+c
+      REAL rlon(klon), rlat(klon), dtime
+      REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
+
+c   Couche limite:
+c   --------------
+c
+      REAL pcoefh(klon,klev)    ! coeff melange CL
+      REAL yv1(klon)
+      REAL yu1(klon),pphis(klon),paire(klon)
+
+c   Les Thermiques : (Abderr 25 11 02)
+c   ---------------
+      REAL pfm_therm(klon,klev+1)
+      real fm_therm1(klon,klev)
+      REAL pentr_therm(klon,klev)
+    
+      REAL,allocatable,save :: entr_therm(:,:)
+      REAL,allocatable,save :: fm_therm(:,:)
+c$OMP THREADPRIVATE(entr_therm)
+c$OMP THREADPRIVATE(fm_therm)
+c
+c   Lessivage:
+c   ----------
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+c
+c Arguments necessaires pour les sources et puits de traceur
+C
+      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c======================================================================
+c
+      INTEGER i, k
+c
+      REAL,allocatable,save :: mfu(:,:)  ! flux de masse dans le panache montant
+      REAL,allocatable,save :: mfd(:,:)  ! flux de masse dans le panache descendant
+      REAL,allocatable,save :: en_u(:,:) ! flux entraine dans le panache montant
+      REAL,allocatable,save :: de_u(:,:) ! flux detraine dans le panache montant
+      REAL,allocatable,save :: en_d(:,:) ! flux entraine dans le panache descendant
+      REAL,allocatable,save :: de_d(:,:) ! flux detraine dans le panache descendant
+      REAL,allocatable,save :: coefh(:,:) ! flux detraine dans le panache descendant
+
+      REAL,allocatable,save :: pyu1(:)
+      REAL,allocatable,save :: pyv1(:)
+      REAL,allocatable,save :: pftsol(:,:)
+      REAL,allocatable,save :: ppsrf(:,:)
+c$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
+c$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
+      real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
+      real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
+
+      REAL dtcum
+
+      integer iadvtr,irec
+      real zmin,zmax
+      logical ok_sync
+ 
+      save dtcum
+      save iadvtr,irec
+c$OMP THREADPRIVATE(dtcum,iadvtr,irec)
+      data iadvtr,irec/0,1/
+      logical,save :: first=.true.
+c$OMP THREADPRIVATE(first)
+c
+c   Couche limite:
+c======================================================================
+
+      ok_sync = .true.
+	print*,'Dans phystokenc.F'
+      print*,'iadvtr= ',iadvtr
+      print*,'istphy= ',istphy
+      print*,'istdyn= ',istdyn
+
+      if (first) then
+      
+        allocate( t(klon,klev))
+        allocate( mfu(klon,klev))  
+        allocate( mfd(klon,klev))  
+        allocate( en_u(klon,klev)) 
+        allocate( de_u(klon,klev)) 
+        allocate( en_d(klon,klev)) 
+        allocate( de_d(klon,klev)) 
+        allocate( coefh(klon,klev)) 
+        allocate( entr_therm(klon,klev))
+        allocate( fm_therm(klon,klev))
+        allocate( pyu1(klon))
+        allocate( pyv1(klon))
+        allocate( pftsol(klon,nbsrf))
+        allocate( ppsrf(klon,nbsrf))
+  
+        first=.false.
+      endif
+      
+      IF (iadvtr.eq.0) THEN
+	
+	CALL initphysto('phystoke',
+     . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)
+  	
+	write(*,*) 'apres initphysto ds phystokenc' 
+
+	
+      ENDIF
+c
+      ndex2d = 0
+      ndex3d = 0
+      i=itap 
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(physid,"phis",i,pphis)
+c
+      i=itap
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+      CALL histwrite_phy(physid,"aire",i,paire)
+
+      iadvtr=iadvtr+1
+c
+      if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
+	print*,'reinitialisation des champs cumules 
+     s          a iadvtr=',iadvtr
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+                t(i,k)=0.
+		fm_therm(i,k)=0.
+               entr_therm(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+                t(i,k)=t(i,k)+pt(i,k)*pdtphys
+       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+
+      IF(mod(iadvtr,istphy).eq.0) THEN 
+c
+c   normalisation par le temps cumule
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=mfu(i,k)/dtcum
+               mfd(i,k)=mfd(i,k)/dtcum
+               en_u(i,k)=en_u(i,k)/dtcum
+               de_u(i,k)=de_u(i,k)/dtcum
+               en_d(i,k)=en_d(i,k)/dtcum
+               de_d(i,k)=de_d(i,k)/dtcum
+               coefh(i,k)=coefh(i,k)/dtcum
+c Unitel a enlever
+	      t(i,k)=t(i,k)/dtcum	
+               fm_therm(i,k)=fm_therm(i,k)/dtcum
+	       entr_therm(i,k)=entr_therm(i,k)/dtcum
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)/dtcum
+            pyu1(i)=pyu1(i)/dtcum
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)/dtcum
+               pftsol1(i) = pftsol(i,1)
+               pftsol2(i) = pftsol(i,2)
+               pftsol3(i) = pftsol(i,3)
+               pftsol4(i) = pftsol(i,4)
+
+               ppsrf(i,k)=ppsrf(i,k)/dtcum
+               ppsrf1(i) = ppsrf(i,1)
+               ppsrf2(i) = ppsrf(i,2)
+               ppsrf3(i) = ppsrf(i,3)
+               ppsrf4(i) = ppsrf(i,4)
+
+            enddo
+         enddo
+c
+c   ecriture des champs
+c
+         irec=irec+1
+
+ccccc
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
+         CALL histwrite_phy(physid,"t",itap,t)
+
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
+      CALL histwrite_phy(physid,"mfu",itap,mfu)
+cym	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
+      CALL histwrite_phy(physid,"mfd",itap,mfd)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_u",itap,en_u)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
+      CALL histwrite_phy(physid,"de_u",itap,de_u)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_d",itap,en_d)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)       
+      CALL histwrite_phy(physid,"de_d",itap,de_d)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)         
+      CALL histwrite_phy(physid,"coefh",itap,coefh)	
+
+c ajou...
+	do k=1,klev
+           do i=1,klon
+	 fm_therm1(i,k)=fm_therm(i,k)	
+	   enddo
+	enddo
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d)
+      CALL histwrite_phy(physid,"fm_th",itap,fm_therm1)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_th",itap,entr_therm)
+cccc
+cym       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
+        CALL histwrite_phy(physid,"frac_impa",itap,frac_impa)
+
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
+        CALL histwrite_phy(physid,"frac_nucl",itap,frac_nucl)
+ 
+cym        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
+      CALL histwrite_phy(physid,"pyu1",itap,pyu1)
+	
+cym	CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
+      CALL histwrite_phy(physid,"pyv1",itap,pyv1)
+	
+cym	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol1",itap,pftsol1)
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol2",itap,pftsol2)
+cym          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol3",itap,pftsol3)
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol4",itap,pftsol4)
+
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf1",itap,ppsrf1)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf2",itap,ppsrf2)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf3",itap,ppsrf3)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf4",itap,ppsrf4)
+
+c$OMP MASTER
+      if (ok_sync) call histsync(physid)
+c$OMP END MASTER
+c     if (ok_sync) call histsync
+	
+c
+cAA Test sur la valeur des coefficients de lessivage 
+c
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_nucl(i,k))
+                  zmin=min(zmin,frac_nucl(i,k))
+            enddo
+         enddo
+         Print*,'------ coefs de lessivage (min et max) --------'
+         Print*,'facteur de nucleation ',zmin,zmax
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_impa(i,k))
+                  zmin=min(zmin,frac_impa(i,k))
+            enddo
+         enddo
+         Print*,'facteur d impaction ',zmin,zmax
+
+      ENDIF 
+
+c   reinitialisation des champs cumules
+	go to 768
+      if (mod(iadvtr,istphy).eq.1) then
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+	       t(i,k)=0.
+               fm_therm(i,k)=0.
+	       entr_therm(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+		t(i,k)=t(i,k)+pt(i,k)*pdtphys
+       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+768   continue
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phytrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phytrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/phytrac.F	(revision 984)
@@ -0,0 +1,957 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phytrac (rnpb,
+     I                    nstep,
+     I                    julien,
+     I                    gmtime,
+     I                    debutphy,
+     I                    lafin,
+     I                    nqmax,
+     I                    nlon,
+     I                    nlev,
+     I                    pdtphys,
+     I                    u,
+     I                    v,
+     I                    t_seri,
+     I                    paprs,
+     I                    pplay,
+     I                    pmfu,
+     I                    pmfd,
+     I                    pen_u,
+     I                    pde_u,
+     I                    pen_d,
+     I                    pde_d,
+     I                    coefh,
+     I                    fm_therm,
+     I                    entr_therm,
+     I                    yu1,
+     I                    yv1,
+     I                    ftsol,
+     I                    pctsrf,
+     I                    xlat,
+     I                    frac_impa,
+     I                    frac_nucl,
+     I                    xlon,
+     I                    presnivs,
+     I                    pphis,
+     I                    pphi,
+     I                    albsol,
+     I                    sh,
+     I                    rh,
+     I                    cldfra,
+     I                    rneb,
+     I                    diafra,
+     I                    cldliq,
+     I                    itop_con,
+     I                    ibas_con,
+     I                    pmflxr,
+     I                    pmflxs,
+     I                    prfl,
+     I                    psfl,
+     I                    da,
+     I                    phi,
+     I                    mp,
+     I                    upwd,
+     I                    dnwd,
+#ifdef INCA
+     I                    flxmass_w,
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+     I                   tau_inca, 
+     I                   piz_inca, 
+     I                   cg_inca,
+     I                   ccm,
+     I                   rfname,
+#endif
+#endif
+     O                    tr_seri)
+
+      USE ioipsl
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE comgeomphy
+      USE iophy
+      USE vampir
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+cAA Remarques en vrac:
+cAA--------------------
+cAA 1/ le call phytrac se fait avec nqmax-2 donc nous avons bien 
+cAA les vrais traceurs (nbtr) dans phytrac (pas la vapeur ni eau liquide)
+cAA 2/ Le choix du radon et du pb se fait juste avec un data 
+cAA    (peu propre). Peut-etre pourrait-on prevoir dans l'avenir 
+cAA    une variable "type de traceur" 
+c======================================================================
+#include "YOMCST.h"
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "paramet.h"
+#include "control.h"
+cym#include "comgeomphy.h"
+#include "advtrac.h"
+#include "thermcell.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon  ! nombre de points horizontaux
+      integer nlev  ! nombre de couches verticales
+      integer nqmax ! nombre de traceurs auxquels on applique la physique
+      integer nstep  ! appel physique
+      integer julien !jour julien
+      integer itop_con(nlon)
+      integer ibas_con(nlon)
+      real gmtime
+      real pdtphys  ! pas d'integration pour la physique (seconde)
+      real t_seri(nlon,nlev) ! temperature
+      real tr_seri(nlon,nlev,nbtr) ! traceur  
+      real u(klon,klev)
+      real v(klon,klev)
+      real sh(nlon,nlev)     ! humidite specifique
+      real rh(nlon,nlev)     ! humidite relative
+      real cldliq(nlon,nlev) ! eau liquide nuageuse
+      real cldfra(nlon,nlev) ! fraction nuageuse (tous les nuages)
+      real diafra(nlon,nlev) ! fraction nuageuse (convection ou stratus artificiels)
+      real rneb(nlon,nlev)   ! fraction nuageuse (grande echelle)
+      real albsol(nlon)  ! albedo surface
+      real paprs(nlon,nlev+1)  ! pression pour chaque inter-couche (en Pa)
+      real ps(nlon)  ! pression surface
+      real pplay(nlon,nlev)  ! pression pour le mileu de chaque couche (en Pa)
+      real pphi(nlon,klev) ! geopotentiel
+      real pphis(klon)
+      REAL presnivs(klev)
+      logical debutphy       ! le flag de l'initialisation de la physique
+      logical lafin          ! le flag de la fin de la physique
+c Olivia      
+      integer nsplit
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--lessivage convection
+      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--lessivage large-scale
+
+#ifdef INCA
+      REAL flxmass_w(klon,klev)
+      CHARACTER(len=8) :: solsym(nqmax)
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      integer la
+      REAL              ::    tau_inca(klon,klev,9,2)
+      REAL              ::    piz_inca(klon,klev,9,2)
+      REAL              ::    cg_inca(klon,klev,9,2)
+      character*4       ::    rfname(9) 
+      REAL              ::    ccm(klon,klev,2) 
+#endif
+#endif
+c      integer iflag_con
+
+cAA Rem : nbtr : nombre de vrais traceurs est defini dans dimphy.h
+c
+c   convection:
+c   -----------
+c
+      REAL pmfu(nlon,nlev)  ! flux de masse dans le panache montant
+      REAL pmfd(nlon,nlev)  ! flux de masse dans le panache descendant
+      REAL pen_u(nlon,nlev) ! flux entraine dans le panache montant
+
+c
+c   thermiques:
+c   -----------
+c
+      real fm_therm(klon,klev+1),entr_therm(klon,klev)
+	real fm_therm1(klon,klev)
+c
+      REAL pde_u(nlon,nlev) ! flux detraine dans le panache montant
+      REAL pen_d(nlon,nlev) ! flux entraine dans le panache descendant
+      REAL pde_d(nlon,nlev) ! flux detraine dans le panache descendant
+c KE
+      real da(nlon,nlev),phi(nlon,nlev,nlev),mp(nlon,nlev)
+      REAL upwd(nlon,nlev)      ! saturated updraft mass flux
+      REAL dnwd(nlon,nlev)      ! saturated downdraft mass flux
+
+c
+c   Couche limite:
+c   --------------
+c
+      REAL coefh(nlon,nlev) ! coeff melange CL
+      REAL yu1(nlon)        ! vents au premier niveau
+      REAL yv1(nlon)        ! vents au premier niveau
+      REAL xlat(nlon)       ! latitudes pour chaque point 
+      REAL xlon(nlon)       ! longitudes pour chaque point 
+
+c
+c   Lessivage:
+c   ----------
+c
+c pour le ON-LINE
+c
+      REAL frac_impa(nlon,nlev)  ! fraction d'aerosols impactes
+      REAL frac_nucl(nlon,nlev)  ! fraction d'aerosols nuclees
+c
+cAA
+cAA Arguments necessaires pour les sources et puits de traceur:
+cAA ----------------
+cAA
+      real ftsol(nlon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(nlon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c abder
+      real pftsol1(nlon),pftsol2(nlon),pftsol3(nlon),pftsol4(nlon)
+      real ppsrf1(nlon),ppsrf2(nlon),ppsrf3(nlon),ppsrf4(nlon)
+c fin
+cAA ----------------------------
+cAA  VARIABLES LOCALES TRACEURS
+cAA ----------------------------
+cAA
+cAA Sources et puits des traceurs:
+cAA ------------------------------
+cAA
+cAA Pour l'instant seuls les cas du rn et du pb ont ete envisages.
+
+      REAL source(klon,nqmax)       ! a voir lorsque le flux est prescrit 
+cAA 
+cAA Pour la source de radon et son reservoir de sol
+cAA ................................................
+ 
+      REAL,save,allocatable :: trs(:,:)    ! Conc. radon ds le sol
+c$OMP THREADPRIVATE(trs)
+cym      SAVE trs
+      REAL :: trs_tmp(klon_glo)
+      
+      REAL,save,allocatable :: masktr(:,:) ! Masque reservoir de sol traceur
+c                            Masque de l'echange avec la surface
+c                           (1 = reservoir) ou (possible => 1 )
+c$OMP THREADPRIVATE(masktr)
+cym      SAVE masktr
+      REAL,save,allocatable :: fshtr(:,:)  ! Flux surfacique dans le reservoir de sol
+c$OMP THREADPRIVATE(fshtr)
+cym      SAVE fshtr
+      REAL,save,allocatable :: hsoltr(:)      ! Epaisseur equivalente du reservoir de sol
+c$OMP THREADPRIVATE(hsoltr)
+cym      SAVE hsoltr
+      REAL,save,allocatable :: tautr(:)       ! Constante de decroissance radioactive
+c$OMP THREADPRIVATE(tautr)
+cym      SAVE tautr
+      REAL,save,allocatable :: vdeptr(:)      ! Vitesse de depot sec dans la couche Brownienne
+c$OMP THREADPRIVATE(vdeptr)
+cym      SAVE vdeptr
+      REAL,save,allocatable :: scavtr(:)      ! Coefficient de lessivage
+c$OMP THREADPRIVATE(scavtr)
+cym      SAVE scavtr
+cAA
+      CHARACTER*2 itn
+C maf ioipsl
+      CHARACTER*2 str2
+      INTEGER nhori, nvert
+      REAL zsto, zout, zjulian
+      INTEGER nid_tra
+      SAVE nid_tra
+c$OMP THREADPRIVATE(nid_tra)
+#ifdef INCA_AER
+      INTEGER nid_tra2,nid_tra3
+      SAVE nid_tra2,nid_tra3
+c$OMP THREADPRIVATE(nid_tra2,nid_tra3)
+#endif
+c     REAL x(klon,klev,nbtr+2) ! traceurs 
+      INTEGER ndex(1)
+      INTEGER ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev)
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+c
+      integer itau_w   ! pas de temps ecriture = nstep + itau_phy
+c
+
+C
+C Variables liees a l'ecriture de la bande histoire : phytrac.nc
+c
+c      INTEGER ecrit_tra
+c      SAVE ecrit_tra 
+
+      logical ok_sync
+      parameter (ok_sync = .true.)
+C
+C nature du traceur
+c
+      logical,save,allocatable :: aerosol(:)  ! Nature du traceur
+c                            ! aerosol(it) = true  => aerosol 
+c                            ! aerosol(it) = false => gaz 
+c                            ! nat_trac(it) = 1. aerosol
+      logical,save,allocatable :: clsol(:)    ! clsol(it) = true => CL sol calculee
+      logical,save,allocatable :: radio(:)    ! radio(it)=true => decroisssance radioactive
+c$OMP THREADPRIVATE(aerosol,clsol,radio)  
+cym      save aerosol,clsol,radio
+C
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+c--modif convection tiedtke
+      INTEGER i, k, it
+      INTEGER iq, iiq
+      REAL delp(klon,klev)
+c--end modif
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c Variables locales pour effectuer les appels en serie
+c----------------------------------------------------
+c
+      REAL d_tr(klon,klev), d_trs(klon) ! tendances de traceurs 
+      REAL d_tr_cl(klon,klev,nbtr) ! tendance de traceurs  couche limite
+      REAL d_tr_cv(klon,klev,nbtr) ! tendance de traceurs  conv pour chq traceur
+      REAL d_tr_th(klon,klev,nbtr) ! la tendance des thermiques
+      REAL d_tr_dec(klon,klev,nbtr) ! la tendance de la decroissance 
+c                                   ! radioactive du rn - > pb 
+      REAL d_tr_lessi_impa(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par impaction
+      REAL d_tr_lessi_nucl(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par nucleation 
+      REAL fluxrn(klon,klev) 
+      REAL fluxpb(klon,klev) 
+      REAL pbimpa(klon,klev) 
+      REAL pbnucl(klon,klev) 
+      REAL rn(klon,klev) 
+      REAL pb(klon,klev) 
+      REAL flestottr(klon,klev,nbtr) ! flux de lessivage 
+c                                    ! dans chaque couche 
+      real zmasse(klon,klev)
+      real ztra_th(klon,klev)
+
+C
+      character*20 modname
+      character*80 abort_message
+c
+c   Controles
+c-------------
+      logical first,couchelimite,convection,lessivage,sorties,
+     s        rnpb,inirnpb
+      save first,couchelimite,convection,lessivage,
+     s        sorties,inirnpb
+c$OMP THREADPRIVATE(first,couchelimite,convection,lessivage,
+c$OMP+              sorties,inirnpb)
+c      data first,couchelimite,convection,lessivage,sorties
+c     s     /.true.,.true.,.false.,.true.,.true./
+c Olivia
+       data first,couchelimite,convection,lessivage,
+     s      sorties
+     s     /.true.,.true.,.true.,.true.,.true./
+
+
+#ifdef INCA
+      INTEGER           :: lastgas
+      INTEGER           :: ncsec
+      INTEGER           :: prt_flag_ts(nbtr)  
+
+      REAL, PARAMETER   :: dry_mass = 28.966
+      REAL, POINTER     :: hbuf(:)
+      REAL, ALLOCATABLE :: obuf(:)
+      REAL              :: calday
+      REAL              :: pdel(klon,klev)
+      REAL              :: dummy(klon,klev)
+#endif
+c
+c======================================================================
+
+#ifdef INCA
+      prt_flag_ts(:)=(/
+#ifdef INCA_CH4
+     .             1,1,1,0,0,1,1,1,1,1,
+     .             0,1,0,0,0,0,0,1,0,0,
+     .             0,1,1,1,1,0,1,1,1,0,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,0,0
+#ifdef INCA_AER 
+     .             ,1,1,1,1,0,1,1,1,1,0,
+     .             1,1,1,1,1,1,0,1,0,1,
+     .             1,1,1,1,0,1,0,1,1,1
+#endif
+#endif
+#ifdef INCA_NMHC
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1
+#ifdef INCA_AER 
+     .             ,1,1,1,1,0,1,1,1,1,0,
+     .             1,1,1,1,1,1,0,1,0,1,
+     .             1,1,1,1,0,1,0,1,1,1
+#endif
+#endif
+#if defined(INCA_AER) && !defined(INCA_CH4) && !defined(INCA_NMHC)
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1
+#endif
+#if defined(INCA) && !defined(INCA_CH4) && !defined(INCA_NMHC) && !defined(INCA_AER)
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1                                         
+#endif
+
+     .             /)
+      dummy(:,:) = 0.
+
+#endif
+         modname='phytrac'
+
+         ps(:)=paprs(:,1)
+
+         if (debutphy) then
+           allocate( trs(klon,nbtr) )
+	   allocate( masktr(klon,nbtr)) 
+           allocate( fshtr(klon,nbtr) )
+           allocate( hsoltr(nbtr))
+           allocate( tautr(nbtr))
+           allocate( vdeptr(nbtr))
+           allocate( scavtr(nbtr))
+           allocate( aerosol(nbtr))
+           allocate( clsol(nbtr))
+           allocate( radio(nbtr))
+
+
+c jg: c'est ca qu'on veut?????           
+!          ecrit_tra = FLOAT(NINT(86400./pdtphys *ecritphy)) 
+          print*,'dans phytrac ',pdtphys,ecrit_tra
+
+         if(nbtr.lt.nqmax) then
+c           print*,'NQMAX=',nqmax
+c           print*,'NBTR=',nbtr
+           abort_message='See above'
+           call abort_gcm(modname,abort_message,1)
+         endif
+
+         inirnpb=rnpb
+         PRINT*, 'La frequence de sortie traceurs est  ', ecrit_tra
+C         
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+#include "ini_histrac.h"
+#endif
+
+c======================================================================
+c   Initialisation de certaines variables pour le Rn et le Pb 
+c======================================================================
+
+c Initialisation du traceur dans le sol (couche limite radonique)
+c
+c        print*,'valeur de debut dans phytrac :',debutphy
+         trs(:,:) = 0.
+c$OMP MASTER         
+       if (is_mpi_root) then
+         trs_tmp(:)=0.
+	 open (99,file='starttrac',status='old',
+     .         err=999,form='formatted')
+         read(99,*) (trs_tmp(i),i=1,klon_glo)
+999      close(99)
+       endif
+c$OMP END MASTER
+       call Scatter(trs_tmp,trs(:,1))
+
+c         print*, 'apres starttrac'
+
+c Initialisation de la fraction d'aerosols lessivee
+c
+         d_tr_lessi_impa(:,:,:) = 0.
+         d_tr_lessi_nucl(:,:,:) = 0. 
+c
+c Initialisation de la nature des traceurs
+c
+         DO it = 1, nqmax
+            aerosol(it) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
+            radio(it) = .FALSE.    ! Par defaut pas de passage par radiornpb
+            clsol(it) = .FALSE.  ! Par defaut couche limite avec flux prescrit
+         ENDDO
+c
+      ENDIF  ! fin debutphy 
+c Initialisation du traceur dans le sol (couche limite radonique)
+      if(inirnpb) THEN
+c
+         radio(1)= .true.
+         radio(2)= .true.
+         clsol(1)= .true.
+         clsol(2)= .true.
+         aerosol(2) = .TRUE. ! le Pb est un aerosol 
+c
+         call initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+         inirnpb=.false.
+      endif
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+!======================================================================
+!     Chimie
+!======================================================================
+
+        calday = FLOAT(julien) + gmtime
+        ncsec  = NINT (86400.*gmtime)
+
+        DO k = 1, nlev
+        pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+        END DO
+
+#ifdef INCAINFO
+        PRINT *, 'CHEMMAIN @ ', calday, ' ... '
+        DO it = 1, nbtr
+        PRINT *, solsym(it), MINVAL(tr_seri(:,:,it)),
+     $                       MAXVAL(tr_seri(:,:,it))
+      END DO
+#endif
+
+
+#ifdef INCA_AER
+        CALL aerosolmain (tr_seri,
+     $                 pdtphys,
+     $                 pplay,
+     $                 pdel,
+     $                 prfl,
+     $                 pmflxr,
+     $                 psfl,
+     $                 pmflxs,
+     $                 pmfu,
+     $                 itop_con,
+     $                 ibas_con,
+     $                 pphi,
+     $                 airephy, ! paire,
+     $                 nstep,
+     $                 rneb,         ! for chimiaq
+     $                 t_seri,       ! for chimiaq
+     $                 rh,
+#ifdef CPP_COUPLE
+     $                 tau_inca,
+     $                 piz_inca,
+     $                 cg_inca,
+     $                 rfname,
+     $                 ccm,
+#endif
+     $                 lafin)
+#endif
+
+        CALL chemmain (tr_seri,    !mmr
+     $                 nstep,      !nstep
+     $                 calday,     !calday
+     $                 julien,     !ncdate
+     $                 ncsec,      !ncsec
+     $                 1,          !lat
+     $                 pdtphys,    !delt
+     $                 paprs(1,1), !ps
+     $                 pplay,      !pmid
+     $                 pdel,       !pdel
+     $                 airephy,
+     $                 pctsrf(1,1),!oro
+     $                 ftsol,      !tsurf
+     $                 albsol,     !albs
+     $                 pphi,       !zma
+     $                 pphis,      !phis
+     $                 cldfra,     !cldfr
+     $                 rneb,       !cldfr_st
+     $                 diafra,     !cldfr_cv
+     $                 itop_con,   !cldtop
+     $                 ibas_con,   !cldbot
+     $                 cldliq,     !cwat
+     $                 prfl,       !flxrst
+     $                 pmflxr,     !flxrcv
+     $                 psfl,       !flxsst
+     $                 pmflxs,     !flxscv
+     $                 pmfu,       !flxupd
+     $                 flxmass_w,  !flxmass_w
+     $                 t_seri,     !tfld
+     $                 sh,         !sh
+     $                 rh,         !rh
+     $                 .false.,    !wrhstts
+     $                 hbuf,       !hbuf
+     $                 obuf,       !obuf
+     $                 iip1,       !nx
+     $                 jjp1,       !ny
+     $                 source,
+     $                 solsym)
+#ifdef INCAINFO
+#ifdef INCA_AER
+
+c Budget calculation for aerosol species
+CALL tbudget(airephy,pdtphys,nstep,tr_seri,.false.)
+
+c-- summary info----------------------------------------------------------------
+
+if (MOD(nstep,nint(86400./pdtphys)) .eq. 0) then
+print *, "global aerosol optical thickness "
+
+write (form,'(A,I2,A)') "(A,",trnx-trmx+1,"A10)"
+print form,"lamba [nm] ", (solsym(it),it=trmx,trnx)
+
+write (form,'(A,I2,A)') "(I11,",trnx-trmx+1,"F10.4)"
+do i=1,las
+print form,int(lambda(i)),(sum(tausum(:,i,it)*airephy)/sum(airephy),it=trmx,trnx)
+enddo
+
+print *,"global mean angstroem component ", sum(angst*airephy)/sum(airephy)
+endif
+#endif
+#endif
+
+#ifdef INCAINFO
+      PRINT *, 'OK.'
+      DO it = 1, nbtr
+      PRINT *, solsym(it), MINVAL(tr_seri(:,:,it)),
+     $                     MAXVAL(tr_seri(:,:,it))
+      END DO
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#else
+
+c Abder
+ctestmaf      if(nqmax.gt.2) aerosol(3)=.true.
+
+       do i=1,nlon
+          pftsol1(i) = ftsol(i,1)
+          pftsol2(i) = ftsol(i,2)
+          pftsol3(i) = ftsol(i,3)
+          pftsol4(i) = ftsol(i,4)
+
+          ppsrf1(i) = pctsrf(i,1)
+          ppsrf2(i) = pctsrf(i,2)
+          ppsrf3(i) = pctsrf(i,3)
+          ppsrf4(i) = pctsrf(i,4)
+
+      enddo
+c Abder
+#endif
+c======================================================================
+c   Calcul de l'effet de la convection
+c======================================================================
+c     print*,'Avant convection'
+c      do it=1,nqmax
+c         WRITE(itn,'(i2)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+c      enddo
+
+      if (convection) then
+
+c      print*,'Pas de temps dans phytrac : ',pdtphys
+      DO it=1, nqmax
+#ifdef INCA
+      IF ( conv_flg(it) == 0 ) CYCLE
+#endif
+      if (iflag_con.eq.2) then
+c tiedke
+      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .            pplay, paprs, tr_seri(1,1,it), d_tr_cv(1,1,it))
+      else if (iflag_con.eq.3) then
+c KE
+      call cvltr(pdtphys, da, phi, mp, paprs,pplay, tr_seri(1,1,it),
+     .           upwd,dnwd,d_tr_cv(1,1,it))
+      endif
+
+      DO k = 1, nlev
+      DO i = 1, klon
+         tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it)
+      ENDDO
+      ENDDO
+#ifdef INCA
+      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '
+     .                              //solsym(it))
+#else
+      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '//itn)
+#endif
+      ENDDO
+c      print*,'apres nflxtr'
+
+      endif ! convection
+c        print*,'Apres convection'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+c      enddo
+
+
+c======================================================================
+c   Calcul de l'effet des thermiques
+c======================================================================
+
+      do k=1,klev
+         do i=1,klon
+            zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
+         enddo
+      enddo
+
+c      print*,'masse dans ph ',zmasse
+      do it=1,nqmax
+         do k=1,klev
+            do i=1,klon
+               d_tr_th(i,k,it)=0.
+               tr_seri(i,k,it)=max(tr_seri(i,k,it),0.)
+               tr_seri(i,k,it)=min(tr_seri(i,k,it),1.e10)
+            enddo
+         enddo
+      enddo
+
+      if (iflag_thermals.gt.0) then
+c        print*,'calcul de leffet des thermiques'
+        nsplit=10
+        DO it=1, nqmax
+c        WRITE(itn,'(i1)') it
+c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'conv it='//itn)
+c	     print*,'avant dqthermiquesretro'
+c             call dump2d(iim,jjm-1,tr_seri(2,1,1),'TR_SERI      ')
+
+         do isplit=1,nsplit
+c  Abderr 25 11 02
+C Thermiques 
+c	print*,'Avant dans phytrac'
+            call dqthermcell(klon,klev,pdtphys/nsplit
+     .       ,fm_therm,entr_therm,zmasse
+     .       ,tr_seri(1:klon,1:klev,it),d_tr,ztra_th)
+
+            do k=1,klev
+               do i=1,klon
+                  d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit
+                  d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k)
+                  tr_seri(i,k,it)=max(tr_seri(i,k,it)+d_tr(i,k),0.)
+               enddo
+            enddo
+          enddo ! nsplit
+c          print*,'apres thermiques'
+c             call dump2d(iim,jjm-1,d_tr_th(1,1,1),'d_tr_th      ')
+c            do k=1,klev
+c	print*,'d_tr_th(',k,')=',tr_seri(280,k,1)
+c	   enddo
+
+c        WRITE(itn,'(i1)') it
+c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'therm it='//itn)
+       ENDDO ! it
+       endif ! Thermiques
+c       print*,'ATTENTION: sdans thermniques'
+      
+c======================================================================
+c   Calcul de l'effet de la couche limite
+c======================================================================
+c	print *,'Avant couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
+      if (couchelimite) then
+
+      DO k = 1, nlev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k)-paprs(i,k+1)
+      ENDDO
+      ENDDO
+
+C maf modif pour tenir compte du cas rnpb + traceur
+      DO it=1, nqmax
+#ifdef INCA
+      IF ( pbl_flg(it) == 0 ) CYCLE
+#endif
+c     print *,'it',it,clsol(it)
+      if (clsol(it)) then  ! couche limite avec quantite dans le sol calculee
+          CALL cltracrn(it, pdtphys, yu1, yv1,
+     e                    coefh,t_seri,ftsol,pctsrf,
+     e                    tr_seri(1,1,it),trs(1,it),
+     e                    paprs, pplay, delp,
+     e                    masktr(1,it),fshtr(1,it),hsoltr(it),
+     e                    tautr(it),vdeptr(it),
+     e                    xlat,
+     s                    d_tr_cl(1,1,it),d_trs)
+          DO k = 1, nlev
+            DO i = 1, klon
+              tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+            ENDDO
+          ENDDO
+c
+c Traceur ds sol
+c
+          DO i = 1, klon
+            trs(i,it) = trs(i,it) + d_trs(i)
+          END DO
+C
+C maf provisoire suppression des prints
+C         WRITE(itn,'(i1)') it
+C         CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracrn it='//itn)
+      else ! couche limite avec flux prescrit
+#ifndef INCA
+
+Cmaf provisoire source / traceur a creer
+        DO i=1, klon
+          source(i,it) = 0.0 ! pas de source, pour l'instant
+        ENDDO
+C
+#endif
+          CALL cltrac(pdtphys, coefh,t_seri,
+     s               tr_seri(1,1,it), source(:,it),
+     e               paprs, pplay, delp,
+     s               d_tr_cl(1,1,it))
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+               ENDDO
+            ENDDO
+Cmaf          WRITE(itn,'(i1)') it
+cmaf          CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracn it='//itn)
+      endif
+      ENDDO
+c
+      endif ! couche limite
+
+c      print*,'Apres couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
+c======================================================================
+c   Calcul de l'effet du puits radioactif
+c======================================================================
+
+C MAF il faudrait faire une modification pour passer dans radiornpb 
+c si radio=true mais pour l'instant radiornpb propre au cas rnpb
+      if(rnpb) then
+c       print *, 'decroissance radiactive activee'
+        call radiornpb (tr_seri,pdtphys,tautr,d_tr_dec)
+C
+        DO it=1,nqmax
+            if(radio(it)) then
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
+               ENDDO
+            ENDDO
+            WRITE(itn,'(i1)') it
+            CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'puits rn it='//itn)
+            endif
+        ENDDO
+c
+      endif ! rnpb decroissance  radioactive
+C
+c======================================================================
+c   Calcul de l'effet de la precipitation
+c======================================================================
+
+c      print*,'LESSIVAGE =',lessivage
+      IF (lessivage) THEN
+
+c     print*,'avant lessivage'
+
+          d_tr_lessi_nucl(:,:,:) = 0. 
+          d_tr_lessi_impa(:,:,:) = 0. 
+          flestottr(:,:,:) = 0. 
+c
+c tendance des aerosols nuclees et impactes 
+c
+       DO it = 1, nqmax
+         IF (aerosol(it)) THEN
+           DO k = 1, nlev
+              DO i = 1, klon
+               d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +
+     s                  ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+               d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +
+     s                  ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c
+c Mises a jour des traceurs + calcul des flux de lessivage 
+c Mise a jour due a l'impaction et a la nucleation
+c
+c      call dump2d(iim,jjm-1,frac_impa(2:klon-1,10),'FRACIMPA')
+c      call dump2d(iim,jjm-1,frac_nucl(2:klon-1,10),'FRACNUCL')
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3')
+       DO it = 1, nqmax
+c         print*,'IT=',it,aerosol(it)
+         IF (aerosol(it)) THEN
+c           print*,'IT=',it,' On lessive'
+           DO k = 1, nlev
+              DO i = 1, klon
+               tr_seri(i,k,it)=tr_seri(i,k,it)
+     s         *frac_impa(i,k)*frac_nucl(i,k)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3B')
+c
+c Flux lessivage total 
+c
+      DO it = 1, nqmax
+           DO k = 1, nlev
+            DO i = 1, klon
+               flestottr(i,k,it) = flestottr(i,k,it) -
+     s                   ( d_tr_lessi_nucl(i,k,it)   +
+     s                     d_tr_lessi_impa(i,k,it) ) *
+     s                   ( paprs(i,k)-paprs(i,k+1) ) / 
+     s                   (RG * pdtphys)
+            ENDDO
+           ENDDO
+c
+Cmaf        WRITE(itn,'(i1)') it
+Cmaf    CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'tr(lessi) it='//itn)
+      ENDDO
+c
+c     print*,'apres lessivage'
+      ENDIF
+Cc
+      DO k = 1, nlev
+         DO i = 1, klon
+            fluxrn(i,k) = flestottr(i,k,1)
+            fluxpb(i,k) = flestottr(i,k,2)
+            rn(i,k) = tr_seri(i,k,1)
+            pb(i,k) = tr_seri(i,k,2)
+            pbnucl(i,k)=d_tr_lessi_nucl(i,k,2)
+            pbimpa(i,k)=d_tr_lessi_impa(i,k,2)
+         ENDDO
+      ENDDO
+
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+#include "write_histrac.h"
+#endif
+
+c=============================================================
+
+      if (lafin) then
+         print*, 'c est la fin de la physique'
+	 call Gather(trs(:,1),trs_tmp)
+c$OMP MASTER	 
+	 if (is_mpi_root) then
+         
+	   open (99,file='restarttrac',  form='formatted')
+           do i=1,klon_glo
+               write(99,*) trs_tmp(i)
+           enddo
+           PRINT*, 'Ecriture du fichier restarttrac'
+           close(99)
+	 endif
+c$OMP END MASTER
+      else
+c         print*, 'physique pas fini'
+      endif
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/plevel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/plevel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/plevel.F	(revision 984)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cy#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cym      INTEGER lt(klon), lb(klon)
+cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb
+c$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+c$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+c$OMP THREADPRIVATE(first)
+      INTEGER i, k
+c
+      if (first) then
+        allocate(lt(klon),lb(klon),aist(klon),aisb(klon))
+	first=.false.
+      endif
+      
+c=====================================================================
+      if (lnew) then
+c   on r�nitialise les r�ndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, klon
+         IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, klon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+            IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, klon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Fr��ic Hourdin (3/01/02)
+
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,klon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, klon
+         if (pgcm(i,1).LT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/printflag.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/printflag.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/printflag.F	(revision 984)
@@ -0,0 +1,183 @@
+!
+! $Header$
+!
+       SUBROUTINE  printflag( tabcntr0, radpas, 
+     ,                        ok_journe,ok_instan,ok_region        )
+c
+
+c
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+       REAL tabcntr0( 100 )
+       LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
+       LOGICAL ok_orolf0,ok_limitvr0
+       LOGICAL ok_journe,ok_instan,ok_region
+       INTEGER radpas , radpas0
+c
+#include "clesphys.h"
+c
+c
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT *,' ********   Choix  des principales  cles de la physique 
+     ,   *********'
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+       PRINT 10, cycle_diurne,  soil_model  
+       PRINT 100
+
+       IF   (    iflag_con.EQ. 1 )   THEN
+           PRINT *,' *****           Shema  convection   LMD            
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 2 )   THEN
+           PRINT *,' *****           Shema  convection  Tiedtke  
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 3 )   THEN
+           PRINT *,' *****           Shema  convection    CCM      
+     ,          ******'
+       ENDIF
+       PRINT 100
+
+       PRINT 11, new_oliq, ok_orodr, ok_orolf   
+       PRINT 100
+
+       PRINT 7,  ok_limitvrai   
+       PRINT 100
+
+       PRINT 12, nbapp_rad
+       PRINT 100
+
+       PRINT 8, radpas
+       PRINT 100
+
+       PRINT 4,ok_journe,ok_instan,ok_region
+       PRINT 100
+       PRINT 100
+c
+c
+        cycle_diurn0  = .FALSE.
+        soil_model0   = .FALSE.
+        new_oliq0     = .FALSE.
+        ok_orodr0     = .FALSE.
+        ok_orolf0     = .FALSE.
+        ok_limitvr0   = .FALSE.
+
+        IF( tabcntr0( 7 ).EQ. 1. )   cycle_diurn0 = .TRUE.
+        IF( tabcntr0( 8 ).EQ. 1. )    soil_model0 = .TRUE.
+        IF( tabcntr0( 9 ).EQ. 1. )      new_oliq0 = .TRUE.
+        IF( tabcntr0(10 ).EQ. 1. )      ok_orodr0 = .TRUE.
+        IF( tabcntr0(11 ).EQ. 1. )      ok_orolf0 = .TRUE.
+        IF( tabcntr0(12 ).EQ. 1. )    ok_limitvr0 = .TRUE.
+
+        PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+     ,$$$$$$$$$$$$$'
+        PRINT 100
+c
+       IF( INT( tabcntr0( 5 ) ) .NE. iflag_con  )   THEN
+        PRINT 20, INT(tabcntr0(5)), iflag_con
+        PRINT 100
+       ENDIF
+
+       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
+        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
+        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+        PRINT 100
+        PRINT 22, radpas0, radpas
+        PRINT 100
+       ENDIF
+
+       IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND.
+     ,        cycle_diurne )     THEN
+        PRINT 13, cycle_diurn0, cycle_diurne
+        PRINT 100
+       ENDIF
+
+       IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND.
+     ,        soil_model )     THEN
+        PRINT 14, soil_model0, soil_model
+        PRINT 100
+       ENDIF
+
+       IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND.
+     ,        new_oliq )     THEN
+        PRINT 16, new_oliq0, new_oliq
+        PRINT 100
+       ENDIF
+
+       IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND.
+     ,        ok_orodr )     THEN
+        PRINT 15, ok_orodr0, ok_orodr
+        PRINT 100
+       ENDIF
+
+       IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND.
+     ,        ok_orolf )     THEN
+        PRINT 17, ok_orolf0, ok_orolf
+        PRINT 100
+       ENDIF
+
+       IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0.
+     ,     AND.ok_limitvrai )     THEN
+        PRINT 18, ok_limitvr0, ok_limitvrai
+        PRINT 100
+       ENDIF
+
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+
+ 4    FORMAT(2x,5(1H*),'  ok_journe= ',l3,3x,',ok_instan = ',
+     , l3,3x,',ok_region = ',l3,3x,5(1H*) )
+
+ 7     FORMAT(2x,5(1H*),15x,'      ok_limitvrai   = ',l3,16x,5(1h*) )
+
+ 8     FORMAT(2x,'*****             radpas    =                      ' ,
+     , i4,6x,' *****')
+
+ 10    FORMAT(2x,5(1H*),'    Cycle_diurne = ',l3,4x,', Soil_model = ',
+     , l3,12x,6(1H*) )
+
+
+ 11    FORMAT(2x,5(1H*),'  new_oliq = ',l3,3x,', Ok_orodr = ',
+     , l3,3x,', Ok_orolf = ',l3,3x,5(1H*) )
+
+
+ 12    FORMAT(2x,'*****  Nb d appels /jour des routines de rayonn. = ' ,
+     , i4,6x,' *****')
+
+ 13    FORMAT(2x,'$$$$$$$$   Attention !!  cycle_diurne  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 14    FORMAT(2x,'$$$$$$$$   Attention !!    soil_model  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 15    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orodr  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 16    FORMAT(2x,'$$$$$$$$   Attention !!      new_oliq  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 17    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orolf  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 18    FORMAT(2x,'$$$$$$$$   Attention !!  ok_limitvrai  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 20    FORMAT(/2x,'$$$$$$$$   Attention !!    iflag_con  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 21    FORMAT(2x,'$$$$$$$$   Attention !!     nbapp_rad  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 22    FORMAT(2x,'$$$$$$$$   Attention !!        radpas  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 100   FORMAT(/)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.160.98.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.160.98.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.160.98.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=78,kflev=klev) ! 78*199
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.192.143.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.192.143.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.192.143.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+       INTEGER kdlon, kflev
+      PARAMETER (kdlon=10,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.32.24.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.32.24.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.32.24.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.48.32.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.48.32.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.48.32.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.72.46.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.72.46.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.72.46.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=1621,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.96.72.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.96.72.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.96.72.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=487,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.defaut.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.defaut.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.defaut.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddim.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddimlw.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddimlw.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/raddimlw.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+      INTEGER NUA
+      PARAMETER (NUA=24)
+      INTEGER NTRA
+      PARAMETER (NTRA=15)
+      INTEGER Ninter
+      PARAMETER (Ninter=6)
+      INTEGER NG1, NG1P1
+      PARAMETER (NG1=2, NG1P1=NG1+1)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radepsi.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radepsi.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radepsi.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      REAL*8 ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW
+      REAL*8 ZEPSEC, ZEPSCR
+      PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines)
+      PARAMETER (ZEPSC  = 1.E-20)
+      PARAMETER (ZEPSCO = 1.E-10)
+      PARAMETER (ZEPSCQ = 1.E-10)
+      PARAMETER (ZEPSCT = 1.E-20)
+      PARAMETER (ZEPSCW = 1.E-20)
+      PARAMETER (ZEPSEC = 1.0E-12)
+      PARAMETER (ZEPSCR = 1.0E-10)
+c
+      REAL*8 REPSCT
+      PARAMETER (REPSCT=1.0E-10)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radiornpb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radiornpb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radiornpb.F	(revision 984)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE radiornpb(tr,dtime,tautr,d_tr) 
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: Decroissance radioactive d'un traceur dans l'atmosphere
+CG240694 : Pour un traceur, le radon
+CG161294 : Plus un 2eme traceur, le 210Pb. Le radon decroit en plomb.
+c======================================================================
+c Arguments:
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c======================================================================
+C
+      INTEGER i , k , it
+      REAL tr(klon,klev,nbtr) , d_tr(klon,klev,nbtr)
+      REAL dtime
+      REAL tautr(nbtr)
+C
+c      WRITE(*,'(''PASSAGE radiornpb ... '',$)')
+C Attention, pour un pas de temps beaucoup plus petit que la decroissance!!!
+
+      DO it = 1,2
+           IF ( tautr(it) .GT. 0. ) THEN
+          	DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
+                END DO
+                END DO
+           ELSE
+                DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = 0.
+                END DO
+                END DO
+           END IF
+      END DO
+C
+CG161294 : Cas particulier radon 1 => plomb 2
+c
+      DO k = 1,klev
+        DO i = 1,klon
+          d_tr(i,k,2) = d_tr(i,k,2) - d_tr(i,k,1)
+        ENDDO
+      ENDDO
+c
+c      WRITE(*,*) ' radiornpb OK'
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radlwsw.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radlwsw.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radlwsw.F	(revision 984)
@@ -0,0 +1,6572 @@
+!
+! $Header$
+!
+      SUBROUTINE radlwsw(dist, rmu0, fract, 
+     .                  paprs, pplay,tsol,albedo, alblw, t,q,wo,
+     .                  cldfra, cldemi, cldtaupd,
+     .                  heat,heat0,cool,cool0,radsol,albpla,
+     .                  topsw,toplw,solsw,sollw,
+     .                  sollwdown,
+     .                  topsw0,toplw0,solsw0,sollw0,
+     .                  lwdn0, lwdn, lwup0, lwup,
+     .                  swdn0, swdn, swup0, swup,
+     .                  ok_ade, ok_aie,
+     .                  tau_ae, piz_ae, cg_ae,
+     .                  topswad, solswad,
+     .                  cldtaupi, topswai, solswai)
+c      
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
+c Objet: interface entre le modele et les rayonnements
+c Arguments:
+c dist-----input-R- distance astronomique terre-soleil
+c rmu0-----input-R- cosinus de l'angle zenithal
+c fract----input-R- duree d'ensoleillement normalisee
+c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
+c solaire--input-R- constante solaire (W/m**2)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c tsol-----input-R- temperature du sol (en K)
+c albedo---input-R- albedo du sol (entre 0 et 1)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (en kg/kg)
+c wo-------input-R- contenu en ozone (en kg/kg) correction MPL 100505
+c cldfra---input-R- fraction nuageuse (entre 0 et 1)
+c cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value)
+c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
+c ok_ade---input-L- apply the Aerosol Direct Effect or not?
+c ok_aie---input-L- apply the Aerosol Indirect Effect or not?
+c tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F)
+c cldtaupi-input-R- epaisseur optique des nuages dans le visible
+c                   calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller
+c                   droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd
+c                   it is needed for the diagnostics of the aerosol indirect radiative forcing      
+c
+c heat-----output-R- echauffement atmospherique (visible) (K/jour)
+c cool-----output-R- refroidissement dans l'IR (K/jour)
+c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
+c albpla---output-R- albedo planetaire (entre 0 et 1)
+c topsw----output-R- flux solaire net au sommet de l'atm.
+c toplw----output-R- ray. IR montant au sommet de l'atmosphere
+c solsw----output-R- flux solaire net a la surface
+c sollw----output-R- ray. IR montant a la surface
+c solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir)
+c topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir)
+c solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind)
+c topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind)
+c
+c ATTENTION: swai and swad have to be interpreted in the following manner:
+c ---------
+c ok_ade=F & ok_aie=F -both are zero
+c ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad
+c                        indirect is zero
+c ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+c                        direct is zero
+c ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+c                        aerosol direct forcing is F_{AD} = topswai-topswad
+c
+      
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOETHF.h"
+c
+      real rmu0(klon), fract(klon), dist
+cIM   real co2_ppm
+cIM   real solaire
+#include "clesphys.h" 
+c
+      real paprs(klon,klev+1), pplay(klon,klev)
+      real albedo(klon), alblw(klon), tsol(klon)
+      real t(klon,klev), q(klon,klev), wo(klon,klev)
+      real cldfra(klon,klev), cldemi(klon,klev), cldtaupd(klon,klev)
+      real heat(klon,klev), cool(klon,klev)
+      real heat0(klon,klev), cool0(klon,klev)
+      real radsol(klon), topsw(klon), toplw(klon)
+      real solsw(klon), sollw(klon), albpla(klon)
+      real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
+      real sollwdown(klon)
+cIM output 3D 
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+c
+      REAL*8 ZFLUP(KDLON,KFLEV+1)
+      REAL*8 ZFLDN(KDLON,KFLEV+1)
+      REAL*8 ZFLUP0(KDLON,KFLEV+1)
+      REAL*8 ZFLDN0(KDLON,KFLEV+1)
+c
+      REAL*8 zx_alpha1, zx_alpha2
+c
+#include "YOMCST.h"
+c
+      INTEGER k, kk, i, j, iof, nb_gr
+      EXTERNAL lw, sw
+c
+cIM ctes ds clesphys.h  REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
+      REAL*8 PSCT
+c
+      REAL*8 PALBD(kdlon,2), PALBP(kdlon,2)
+      REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
+      REAL*8 PPSOL(kdlon), PDP(kdlon,klev)
+      REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
+      REAL*8 PTAVE(kdlon,kflev)
+      REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev)
+      REAL*8 PAER(kdlon,kflev,5)
+      REAL*8 PCLDLD(kdlon,kflev)
+      REAL*8 PCLDLU(kdlon,kflev)
+      REAL*8 PCLDSW(kdlon,kflev)
+      REAL*8 PTAU(kdlon,2,kflev)
+      REAL*8 POMEGA(kdlon,2,kflev)
+      REAL*8 PCG(kdlon,2,kflev)
+c
+      REAL*8 zfract(kdlon), zrmu0(kdlon), zdist
+c
+      REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev)
+      REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev)
+      REAL*8 ztopsw(kdlon), ztoplw(kdlon)
+      REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
+cIM
+      REAL*8 zsollwdown(kdlon)
+c
+      REAL*8 ztopsw0(kdlon), ztoplw0(kdlon)
+      REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
+      REAL*8 zznormcp
+cIM output 3D : SWup, SWdn, LWup, LWdn
+      REAL swdn(klon,kflev+1),swdn0(klon,kflev+1)
+      REAL swup(klon,kflev+1),swup0(klon,kflev+1)
+      REAL lwdn(klon,kflev+1),lwdn0(klon,kflev+1)
+      REAL lwup(klon,kflev+1),lwup0(klon,kflev+1)
+c-OB
+cjq the following quantities are needed for the aerosol radiative forcings
+
+      real topswad(klon), solswad(klon) ! output: aerosol direct forcing at TOA and surface
+      real topswai(klon), solswai(klon) ! output: aerosol indirect forcing atTOA and surface
+      real tau_ae(klon,klev,2), piz_ae(klon,klev,2), cg_ae(klon,klev,2) ! aerosol optical properties (see aeropt.F)
+      real cldtaupi(klon,klev)  ! cloud optical thickness for pre-industrial aerosol concentrations
+                                ! (i.e., with a smaller droplet concentrationand thus larger droplet radii)
+      logical ok_ade, ok_aie    ! switches whether to use aerosol direct (indirect) effects or not
+      real*8 tauae(kdlon,kflev,2) ! aer opt properties
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use
+      REAL*8 POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo
+      REAL*8 ztopswad(kdlon), zsolswad(kdlon) ! Aerosol direct forcing at TOAand surface
+      REAL*8 ztopswai(kdlon), zsolswai(kdlon) ! dito, indirect
+cjq-end
+!rv
+      tauae(:,:,:)=0.
+      pizae(:,:,:)=0.
+      cgae(:,:,:)=0.
+!rv
+      
+c
+c-------------------------------------------
+      nb_gr = klon / kdlon
+      IF (nb_gr*kdlon .NE. klon) THEN
+         PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr
+         CALL abort
+      ENDIF
+      IF (kflev .NE. klev) THEN
+          PRINT*, "kflev differe de klev, kflev, klev"
+          CALL abort
+      ENDIF
+c-------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         heat(i,k)=0.
+         cool(i,k)=0.
+         heat0(i,k)=0.
+         cool0(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      zdist = dist
+c
+cIM anciennes valeurs
+c     RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97
+c
+cIM : on met RCO2, RCH4, RN2O, RCFC11 et RCFC12 dans clesphys.h /lecture ds conf_phys.F90
+c     RCH4 = 1.65E-06* 16.043/28.97
+c     RN2O = 306.E-09* 44.013/28.97
+c     RCFC11 = 280.E-12* 137.3686/28.97
+c     RCFC12 = 484.E-12* 120.9140/28.97
+cIM anciennes valeurs
+c     RCH4 = 1.72E-06* 16.043/28.97
+c     RN2O = 310.E-09* 44.013/28.97
+c
+c     PRINT*,'IMradlwsw : solaire, co2= ', solaire, co2_ppm
+      PSCT = solaire/zdist/zdist
+c
+      DO 99999 j = 1, nb_gr
+      iof = kdlon*(j-1)
+c
+      DO i = 1, kdlon
+         zfract(i) = fract(iof+i)
+         zrmu0(i) = rmu0(iof+i)
+         PALBD(i,1) = albedo(iof+i)
+!         PALBD(i,2) = albedo(iof+i)
+         PALBD(i,2) = alblw(iof+i)
+         PALBP(i,1) = albedo(iof+i)
+!         PALBP(i,2) = albedo(iof+i)
+         PALBP(i,2) = alblw(iof+i)
+cIM cf. JLD pour etre en accord avec ORCHIDEE il faut mettre PEMIS(i) = 0.96
+         PEMIS(i) = 1.0 
+         PVIEW(i) = 1.66
+         PPSOL(i) = paprs(iof+i,1)
+         zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2)) 
+     .             / (pplay(iof+i,1)-pplay(iof+i,2))
+         zx_alpha2 = 1.0 - zx_alpha1
+         PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
+         PTL(i,klev+1) = t(iof+i,klev)
+         PDT0(i) = tsol(iof+i) - PTL(i,1)
+      ENDDO
+      DO k = 2, kflev
+      DO i = 1, kdlon
+         PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
+      ENDDO
+      ENDDO
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
+         PTAVE(i,k) = t(iof+i,k)
+         PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
+         PQS(i,k) = PWV(i,k)
+c wo:    cm.atm (epaisseur en cm dans la situation standard)
+c POZON: kg/kg
+         POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968
+     .               /(paprs(iof+i,k)-paprs(iof+i,k+1))
+     .               *(paprs(iof+i,1)/101325.0)
+         PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDSW(i,k) = cldfra(iof+i,k)
+         PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
+         POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
+         PCG(i,1,k) = 0.865
+         PCG(i,2,k) = 0.910
+c-OB
+cjq Introduced for aerosol indirect forcings.
+cjq The following values use the cloud optical thickness calculated from
+cjq present-day aerosol concentrations whereas the quantities without the
+cjq "A" at the end are for pre-industial (natural-only) aerosol concentrations
+cjq
+         PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k))
+         POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k))
+cjq-end
+      ENDDO
+      ENDDO
+c
+      DO k = 1, kflev+1
+      DO i = 1, kdlon
+         PPMB(i,k) = paprs(iof+i,k)/100.0
+      ENDDO
+      ENDDO
+c
+      DO kk = 1, 5
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PAER(i,k,kk) = 1.0E-15
+      ENDDO
+      ENDDO
+      ENDDO
+c-OB
+      DO k = 1, kflev
+      DO i = 1, kdlon
+        tauae(i,k,1)=tau_ae(iof+i,k,1)
+        pizae(i,k,1)=piz_ae(iof+i,k,1)
+        cgae(i,k,1) =cg_ae(iof+i,k,1)
+        tauae(i,k,2)=tau_ae(iof+i,k,2)
+        pizae(i,k,2)=piz_ae(iof+i,k,2)
+        cgae(i,k,2) =cg_ae(iof+i,k,2)
+      ENDDO
+      ENDDO
+c
+c======================================================================
+cIM ctes ds clesphys.h   CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      CALL LW(
+     .        PPMB, PDP,
+     .        PPSOL,PDT0,PEMIS,
+     .        PTL, PTAVE, PWV, POZON, PAER,
+     .        PCLDLD,PCLDLU,
+     .        PVIEW,
+     .        zcool, zcool0,
+     .        ztoplw,zsollw,ztoplw0,zsollw0,
+     .        zsollwdown,
+     .        ZFLUP, ZFLDN, ZFLUP0,ZFLDN0)
+cIM ctes ds clesphys.h   CALL SW(PSCT, RCO2, zrmu0, zfract,
+      CALL SW(PSCT, zrmu0, zfract,
+     S        PPMB, PDP,
+     S        PPSOL, PALBD, PALBP,
+     S        PTAVE, PWV, PQS, POZON, PAER,
+     S        PCLDSW, PTAU, POMEGA, PCG,
+     S        zheat, zheat0,
+     S        zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,
+     S        ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S        tauae, pizae, cgae, ! aerosol optical properties
+     s        PTAUA, POMEGAA,
+     s        ztopswad,zsolswad,ztopswai,zsolswai, ! diagnosed aerosol forcing
+     J        ok_ade, ok_aie) ! apply aerosol effects or not?
+
+c======================================================================
+      DO i = 1, kdlon
+         radsol(iof+i) = zsolsw(i) + zsollw(i)
+         topsw(iof+i) = ztopsw(i)
+         toplw(iof+i) = ztoplw(i)
+         solsw(iof+i) = zsolsw(i)
+         sollw(iof+i) = zsollw(i)
+         sollwdown(iof+i) = zsollwdown(i)
+cIM
+         DO k = 1, kflev+1
+         lwdn0 ( iof+i,k)   = ZFLDN0 ( i,k)
+         lwdn  ( iof+i,k)   = ZFLDN  ( i,k)
+         lwup0 ( iof+i,k)   = ZFLUP0 ( i,k)
+         lwup  ( iof+i,k)   = ZFLUP  ( i,k)
+         ENDDO
+c
+         topsw0(iof+i) = ztopsw0(i)
+         toplw0(iof+i) = ztoplw0(i)
+         solsw0(iof+i) = zsolsw0(i)
+         sollw0(iof+i) = zsollw0(i)
+         albpla(iof+i) = zalbpla(i)
+cIM
+         DO k = 1, kflev+1
+         swdn0 ( iof+i,k)   = ZFSDN0 ( i,k)
+         swdn  ( iof+i,k)   = ZFSDN  ( i,k)
+         swup0 ( iof+i,k)   = ZFSUP0 ( i,k)
+         swup  ( iof+i,k)   = ZFSUP  ( i,k)
+         ENDDO !k=1, kflev+1
+      ENDDO
+cjq-transform the aerosol forcings, if they have
+cjq to be calculated
+      IF (ok_ade) THEN
+      DO i = 1, kdlon
+         topswad(iof+i) = ztopswad(i)
+         solswad(iof+i) = zsolswad(i)
+      ENDDO
+      ELSE
+      DO i = 1, kdlon
+         topswad(iof+i) = 0.0
+         solswad(iof+i) = 0.0
+      ENDDO
+      ENDIF
+      IF (ok_aie) THEN
+      DO i = 1, kdlon
+         topswai(iof+i) = ztopswai(i)
+         solswai(iof+i) = zsolswai(i)
+      ENDDO
+      ELSE
+      DO i = 1, kdlon
+         topswai(iof+i) = 0.0
+         solswai(iof+i) = 0.0
+      ENDDO
+      ENDIF
+cjq-end
+      DO k = 1, kflev
+c      DO i = 1, kdlon
+c         heat(iof+i,k) = zheat(i,k)
+c         cool(iof+i,k) = zcool(i,k)
+c         heat0(iof+i,k) = zheat0(i,k)
+c         cool0(iof+i,k) = zcool0(i,k)
+c      ENDDO
+      DO i = 1, kdlon
+C        scale factor to take into account the difference between
+C        dry air and watter vapour scpecific heat capacity
+         zznormcp=1.0+RVTMP2*PWV(i,k)
+         heat(iof+i,k) = zheat(i,k)/zznormcp
+         cool(iof+i,k) = zcool(i,k)/zznormcp
+         heat0(iof+i,k) = zheat0(i,k)/zznormcp
+         cool0(iof+i,k) = zcool0(i,k)/zznormcp
+      ENDDO
+      ENDDO
+c
+99999 CONTINUE
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+      SUBROUTINE SW(PSCT, PRMU0, PFRAC, 
+     S              PPMB, PDP, 
+     S              PPSOL, PALBD, PALBP,
+     S              PTAVE, PWV, PQS, POZON, PAER,
+     S              PCLDSW, PTAU, POMEGA, PCG,
+     S              PHEAT, PHEAT0,
+     S              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
+     S              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S              tauae, pizae, cgae,
+     s              PTAUA, POMEGAA,
+     S              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
+     J              ok_ade, ok_aie )
+      USE dimphy      
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOMCST.h"
+C
+C     ------------------------------------------------------------------
+C
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT  ! constante solaire (valeur conseillee: 1370)
+cIM ctes ds clesphys.h   REAL*8 RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+#include "clesphys.h"
+C
+      REAL*8 PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL*8 PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+C
+      REAL*8 PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL*8 PFRAC(KDLON)  ! fraction de la journee
+C
+      REAL*8 PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL*8 PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL*8 PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL*8 POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+C
+      REAL*8 PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL*8 PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+C
+      REAL*8 PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL*8 PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL*8 PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL*8 POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+C
+      REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL*8 PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL*8 PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL*8 PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL*8 PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZOZ(KDLON,KFLEV)
+      REAL*8 ZAKI(KDLON,2)     
+      REAL*8 ZCLD(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON) 
+      REAL*8 ZDSIG(KDLON,KFLEV)
+      REAL*8 ZFACT(KDLON)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFDOWN(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1)
+      REAL*8 ZFUP(KDLON,KFLEV+1)
+      REAL*8 ZRMU(KDLON)
+      REAL*8 ZSEC(KDLON)
+      REAL*8 ZUD(KDLON,5,KFLEV+1)
+      REAL*8 ZCLDSW0(KDLON,KFLEV)
+c
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+C
+      INTEGER inu, jl, jk, i, k, kpl1
+c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+      SAVE itapsw,appel1er
+c$OMP THREADPRIVATE(appel1er)
+c$OMP THREADPRIVATE(itapsw)
+cjq-Introduced for aerosol forcings
+      real*8 flag_aer
+      logical ok_ade, ok_aie    ! use aerosol forcings or not?
+      real*8 tauae(kdlon,kflev,2)  ! aerosol optical properties
+      real*8 pizae(kdlon,kflev,2)  ! (see aeropt.F)
+      real*8 cgae(kdlon,kflev,2)   ! -"-
+      REAL*8 PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+      REAL*8 POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+      REAL*8 PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+      REAL*8 PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+      REAL*8 PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+      REAL*8 PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+cjq - Fluxes including aerosol effects
+      REAL*8,allocatable,save :: ZFSUPAD(:,:)
+c$OMP THREADPRIVATE(ZFSUPAD)
+      REAL*8,allocatable,save :: ZFSDNAD(:,:)
+c$OMP THREADPRIVATE(ZFSDNAD)
+      REAL*8,allocatable,save :: ZFSUPAI(:,:)
+c$OMP THREADPRIVATE(ZFSUPAI)
+      REAL*8,allocatable,save :: ZFSDNAI(:,:)
+c$OMP THREADPRIVATE(ZFSDNAI)
+      logical initialized
+cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+!rv
+      save flag_aer
+c$OMP THREADPRIVATE(flag_aer)
+      data initialized/.false./
+      save initialized
+c$OMP THREADPRIVATE(initialized)
+cjq-end
+      if(.not.initialized) then
+        flag_aer=0.
+        initialized=.TRUE.
+        allocate(ZFSUPAD(KDLON,KFLEV+1))
+        allocate(ZFSDNAD(KDLON,KFLEV+1))
+        allocate(ZFSUPAI(KDLON,KFLEV+1))
+        allocate(ZFSDNAI(KDLON,KFLEV+1))
+	ZFSUPAD(:,:)=0.
+        ZFSDNAD(:,:)=0.
+        ZFSUPAI(:,:)=0.
+        ZFSDNAI(:,:)=0.
+	
+      endif
+!rv
+      
+c
+      IF (appel1er) THEN
+         PRINT*, 'SW calling frequency : ', swpas
+         PRINT*, "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+c
+      DO JK = 1 , KFLEV
+      DO JL = 1, KDLON
+         ZCLDSW0(JL,JK) = 0.0
+         ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
+     .               *PDP(JL,JK)*(101325.0/PPSOL(JL))
+      ENDDO
+      ENDDO
+C
+C
+c clear-sky:
+cIM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+      CALL SWU(PSCT,ZCLDSW0,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+      flag_aer=0.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+
+c cloudy-sky:
+      
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+c      
+      IF (ok_ade) THEN
+c
+c cloudy-sky + aerosol dir OB
+      flag_aer=1.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO 
+      
+      ENDIF ! ok_ade
+      
+      IF (ok_aie) THEN
+         
+cjq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer=1.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAI(JL,JK) = ZFSDN(JL,JK)          
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      ENDIF ! ok_aie      
+cjq -end
+      
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
+     .                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
+     .                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+c-OB
+         PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
+         PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
+c
+         PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
+         PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
+c-fin 
+      ENDDO
+C
+      RETURN
+      END
+c
+cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+      SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+     S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
+     S                PRMU,PSEC,PUD)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT
+cIM ctes ds clesphys.h   REAL*8 RCO2
+#include "clesphys.h"
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 PRMU0(KDLON)
+      REAL*8 PFRAC(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PFACT(KDLON)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(2)
+      REAL*8 ZC1J(KDLON,KFLEV+1)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZN175(KDLON)
+      REAL*8 ZN190(KDLON)
+      REAL*8 ZO175(KDLON)
+      REAL*8 ZO190(KDLON)
+      REAL*8 ZSIGN(KDLON)
+      REAL*8 ZR(KDLON,2) 
+      REAL*8 ZSIGO(KDLON)
+      REAL*8 ZUD(KDLON,2)
+      REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+C
+C* Prescribed Data:
+c
+      REAL*8 ZPDH2O,ZPDUMG
+      SAVE ZPDH2O,ZPDUMG
+c$OMP THREADPRIVATE(ZPDH2O,ZPDUMG)
+      REAL*8 ZPRH2O,ZPRUMG
+      SAVE ZPRH2O,ZPRUMG
+c$OMP THREADPRIVATE(ZPRH2O,ZPRUMG)
+      REAL*8 RTDH2O,RTDUMG
+      SAVE RTDH2O,RTDUMG
+c$OMP THREADPRIVATE(RTDH2O,RTDUMG)
+      REAL*8 RTH2O ,RTUMG
+      SAVE RTH2O ,RTUMG
+c$OMP THREADPRIVATE(RTH2O ,RTUMG)
+      DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /
+      DATA ZPRH2O,ZPRUMG / 30000., 30000. /
+      DATA RTDH2O,RTDUMG /  0.40  , 0.375 /
+      DATA RTH2O ,RTUMG  /  240.  , 240.  /
+C     ------------------------------------------------------------------
+C
+C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+C                 -----------------------------
+C
+ 100  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=2
+C      
+C
+C*         1.1    INITIALIZES QUANTITIES
+C                 ----------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+C
+C*          1.3    AMOUNTS OF ABSORBERS
+C                  --------------------
+C
+ 130  CONTINUE
+C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
+     .             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
+     .             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)
+     S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
+     S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+C      
+C
+C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+C                 -----------------------------------------------
+C
+ 140  CONTINUE
+C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+C
+      CALL SWTT1(2, 2, IIND, ZUD, ZR)
+C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW1S ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW
+     S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD  
+     S  ,  PFD   , PFU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)  
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+      REAL*8 PFD(KDLON,KFLEV+1)
+      REAL*8 PFU(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(4)
+C      
+      REAL*8 ZCGAZ(KDLON,KFLEV) 
+      REAL*8 ZDIFF(KDLON)
+      REAL*8 ZDIRF(KDLON)        
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZR(KDLON,4)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZW(KDLON,4)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+c
+c Prescribed Data:
+c
+      REAL*8 RSUN(2)
+      SAVE RSUN
+c$OMP THREADPRIVATE(RSUN)
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+c$OMP THREADPRIVATE(RRAY)
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C     ------------------------------------------------------------------
+C
+C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+C                 ----------------------- ------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
+     S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
+     S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL
+     S  , PSEC  ,PTAU
+     S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE
+     S  , ZTAUAZ,ZTRA1 ,ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    OZONE ABSORPTION
+C                ----------------
+C
+ 300  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+C      
+C
+C*         3.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 310  CONTINUE
+C
+      JAJ = 2
+C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
+     S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+C
+C
+C*         3.2   UPWARD FLUXES
+C                -------------
+C
+ 320  CONTINUE
+C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
+     S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
+     S          * RSUN(KNU)
+ 325  CONTINUE
+C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW2S ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW
+     S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU
+     S  ,  PUD   ,PWV , PQS
+     S  ,  PFDOWN,PFUP                                            )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+C     A GREY MOLECULAR ABSORPTION
+C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+C     OF ABSORBERS
+C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PQS(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PFDOWN(KDLON,KFLEV+1)
+      REAL*8 PFUP(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND2(2), IIND3(3)
+      REAL*8 ZCGAZ(KDLON,KFLEV)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1) 
+      REAL*8 ZG(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRL(KDLON,8)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZRUEF(KDLON,8)
+      REAL*8 ZR1(KDLON) 
+      REAL*8 ZR2(KDLON,2)
+      REAL*8 ZR3(KDLON,3)
+      REAL*8 ZR4(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZS(KDLON)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)   
+      REAL*8 ZW1(KDLON)
+      REAL*8 ZW2(KDLON,2)
+      REAL*8 ZW3(KDLON,3)
+      REAL*8 ZW4(KDLON)
+      REAL*8 ZW5(KDLON)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+C
+C* Prescribed Data:
+C
+      REAL*8 RSUN(2)
+      SAVE RSUN
+c$OMP THREADPRIVATE(RSUN)
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+c$OMP THREADPRIVATE(RRAY)
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C
+C     ------------------------------------------------------------------
+C
+C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+C                 -------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1
+     S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1
+     S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC 
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL
+     S  , PSEC  , PTAU
+     S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE
+     S  , ZTAUAZ, ZTRA1 , ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+C                ------------------------------------------------------
+C
+ 300  CONTINUE
+C
+      JN = 2
+C
+      DO 361 JABS=1,2
+C
+C
+C*         3.1  SURFACE CONDITIONS
+C               ------------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+C
+C
+C*         3.2  INTRODUCING CLOUD EFFECTS
+C               -------------------------
+C
+ 320  CONTINUE
+C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
+     S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
+     S               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+C
+      CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
+     S          ZRE1, ZRE2, ZTR1, ZTR2)
+C
+      DO 323 JL = 1, KDLON
+C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
+     S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
+     S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
+     S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
+     S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
+     S             + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
+     S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
+     S              * ZREFZ(JL,1,JKM1)))
+     S              * ZG(JL) * (1. -ZRNEB(JL))
+C
+ 323  CONTINUE
+ 324  CONTINUE
+C
+C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C               -------------------------------------------------
+C
+ 330  CONTINUE
+C
+      DO 351 JREF=1,2
+C
+      JN = JN + 1
+C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         4.    INVERT GREY AND CONTINUUM FLUXES
+C                --------------------------------
+C
+ 400  CONTINUE
+C
+C
+C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+C                ---------------------------------------------
+C
+ 410  CONTINUE
+C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+C
+C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+C                 ---------------------------------------------
+C
+ 420  CONTINUE
+C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+C
+C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+C                 --------------------------
+C
+ 4210 CONTINUE
+C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+C
+C*         4.2.2  TRANSMISSION FUNCTION
+C                 ---------------------
+C
+ 4220 CONTINUE
+C
+      CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
+C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+C
+C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+C                 ------------------------------------------------------
+C
+ 430  CONTINUE
+C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
+     S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
+     S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+C                ----------------------------------------
+C
+ 500  CONTINUE
+C
+C
+C*         5.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 510  CONTINUE
+C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 513 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+C
+C
+C*         5.2   UPWARD FLUXES
+C                -------------
+C
+ 520  CONTINUE
+C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 527 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+C                 --------------------------------------------------
+C
+ 600  CONTINUE
+      IABS=3
+C
+C*         6.1    DOWNWARD FLUXES
+C                 ---------------
+C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
+     S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
+     S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+C
+C
+C*         6.2    UPWARD FLUXES
+C                 -------------
+C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
+     S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
+     S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWCLR  ( KNU
+     S  , PAER  , flag_aer, tauae, pizae, cgae
+     S  , PALBP , PDSIG , PRAYL , PSEC
+     S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ  
+     S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CLEAR-SKY COLUMN
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 94-11-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+C
+      REAL*8 PCGAZ(KDLON,KFLEV)     
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMU0(KDLON,KFLEV+1)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC0I(KDLON,KFLEV+1)       
+      REAL*8 ZCLE0(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS0(KDLON)
+      REAL*8 ZSCAT(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL*8 ZBMU0, ZBMU1, ZRE11
+C
+C* Prescribed Data for Aerosols:
+C
+      REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
+      SAVE TAUA, RPIZA, RCGA
+c$OMP THREADPRIVATE(TAUA, RPIZA, RCGA)
+      DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
+     S .730719, .912819, .725059, .745405, .682188 ,
+     S .730719, .912819, .725059, .745405, .682188 /
+      DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
+     S .872212, .982545, .623143, .944887, .997975 ,
+     S .872212, .982545, .623143, .944887, .997975 /
+      DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
+     S .647596, .739002, .580845, .662657, .624246 ,
+     S .647596, .739002, .580845, .662657, .624246 /
+C     ------------------------------------------------------------------
+C
+C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+C                --------------------------------------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+      DO 108 JK = 1 , KFLEV
+c-OB
+c      DO 104 JL = 1, KDLON
+c      PCGAZ(JL,JK) = 0.
+c      PPIZAZ(JL,JK) =  0.
+c      PTAUAZ(JL,JK) = 0.
+c 104  CONTINUE
+c-OB
+c      DO 106 JAE=1,5
+c      DO 105 JL = 1, KDLON
+c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+c 105  CONTINUE
+c 106  CONTINUE
+c-OB
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
+      PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
+      PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
+ 105  CONTINUE
+C
+      IF (flag_aer.GT.0) THEN
+c-OB
+      DO 107 JL = 1, KDLON
+c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
+     S                       / (1. - PPIZAZ(JL,JK) * ZFF)
+ 107  CONTINUE
+      ELSE
+      DO JL = 1, KDLON
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END DO
+      END IF   ! check flag_aer
+c     107  CONTINUE
+c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+C
+ 108  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
+     S            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
+     S  , PSEC  , PTAU
+     S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
+     S  , PTAUAZ, PTRA1 , PTRA2 )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CONTINUUM SCATTERING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+C
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMUE(KDLON,KFLEV+1)
+      REAL*8 PCGAZ(KDLON,KFLEV)
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC1I(KDLON,KFLEV+1)
+      REAL*8 ZCLEQ(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS1(KDLON)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)
+C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
+C
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
+     S            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.3  EFFECT OF CLOUD LAYER
+C               ---------------------
+C
+ 330  CONTINUE
+C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
+     S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+C machine
+C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+C
+      CALL SWDE(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
+     S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+C
+      DO 345 JL = 1, KDLON
+C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               * (1.-ZRNEB(JL))
+C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
+     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
+     S                 PRE1,PRE2,PTR1,PTR2)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+C
+C     METHOD.
+C     -------
+C
+C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      REAL*8 PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL*8 PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL*8 PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL*8 PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL*8 PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL*8 PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER jl
+      REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
+      REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL*8 ZRI0B, ZRI1B
+      REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
+C     ------------------------------------------------------------------
+C
+C*         1.      DELTA-EDDINGTON CALCULATIONS
+C
+ 100  CONTINUE
+C
+      DO 131 JL   =   1, KDLON
+C
+C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+C
+ 110  CONTINUE
+C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+CMAF      ZARG=MIN(ZTOP/PRMUZ(JL),200.)
+      ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
+      ZEXMU0=EXP(-ZARG)
+CMAF      ZARG2=MIN(ZRK*ZTOP,200.)
+      ZARG2=MIN(ZRK*ZTOP,2.0d+2)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+C
+C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+C
+ 120  CONTINUE
+C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+C
+C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+C
+ 130  CONTINUE
+C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+C
+ 131  CONTINUE
+      RETURN
+      END
+      SUBROUTINE SWTT (KNU,KA,PU,PTR)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS
+C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL*8 PU(KDLON)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+c$OMP THREADPRIVATE(APAD, BPAD, D)
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
+     S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
+     S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
+     S      * ( APAD(KNU,KA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
+     S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
+     S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
+     S      * ( BPAD(KNU,KA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 95-01-20
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL*8 PU(KDLON,KABS)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON)
+      REAL*8 ZR2(KDLON)
+      REAL*8 ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+c$OMP THREADPRIVATE(APAD, BPAD, D)
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
+     S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
+     S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
+     S      * ( APAD(KNU,IA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
+     S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
+     S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
+     S      * ( BPAD(KNU,IA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+C
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      SUBROUTINE LW(
+     .              PPMB, PDP,
+     .              PPSOL,PDT0,PEMIS,
+     .              PTL, PTAVE, PWV, POZON, PAER,
+     .              PCLDLD,PCLDLU,
+     .              PVIEW,
+     .              PCOLR, PCOLR0,
+     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
+     .              psollwdown,
+cIM  .              psollwdown,psollwdownclr,
+cIM  .              ptoplwdown,ptoplwdownclr)
+     .              plwup, plwdn, plwup0, plwdn0)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+cIM ctes ds clesphys.h
+c     REAL*8 RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+c     REAL*8 RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+c     REAL*8 RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+c     REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+c     REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+#include "clesphys.h"
+      REAL*8 PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL*8 PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL*8 PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL*8 PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL*8 PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL*8 PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL*8 POZON(KDLON,KFLEV)   ! O3 CONCENTRATION (kg/kg)
+      REAL*8 PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL*8 PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL*8 PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL*8 PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL*8 PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+C
+      REAL*8 PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL*8 PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL*8 PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL*8 PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      REAL*8 PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+c Rajout LF
+      real*8 psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
+c Rajout IM
+cIM   real*8 psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
+cIM   real*8 ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
+cIM   real*8 ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
+cIM
+      REAL*8 plwup(KDLON,KFLEV+1)  ! LW up total sky
+      REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky
+      REAL*8 plwdn(KDLON,KFLEV+1)  ! LW down total sky
+      REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky
+C-------------------------------------------------------------------------
+      REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZOZ(KDLON,KFLEV)
+c
+cym      REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+cym      REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+cym      REAL*8 ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+cym      REAL*8 ZBSUI(KDLON)                    ! Intermediate variable
+cym      REAL*8,ZCTS(KDLON,KFLEV)               ! Intermediate variable
+cym      REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+      REAL*8,allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL*8,allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8,allocatable,save :: ZBINT(:,:)            ! Intermediate variable
+      REAL*8,allocatable,save :: ZBSUI(:)                    ! Intermediate variable
+      REAL*8,allocatable,save :: ZCTS(:,:)               ! Intermediate variable
+      REAL*8,allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
+c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+c
+      INTEGER ilim, i, k, kpl1
+C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+
+C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         PRINT*, "LW clear-sky calling frequency: ", lw0pas
+         PRINT*, "LW cloudy-sky calling frequency: ", lwpas
+         PRINT*, "   In general, they should be 1"
+cym
+	 allocate(ZFLUX(KDLON,2,KFLEV+1) )
+         allocate(ZFLUC(KDLON,2,KFLEV+1) )
+         allocate(ZBINT(KDLON,KFLEV+1))
+         allocate(ZBSUI(KDLON))
+         allocate(ZCTS(KDLON,KFLEV))
+         allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
+         appel1er=.FALSE.
+      ENDIF
+C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+      DO k = 1, KFLEV  ! convertir ozone de kg/kg en pa/pa
+      DO i = 1, KDLON
+c convertir ozone de kg/kg en pa (modif MPL 100505)
+         ZOZ(i,k) = POZON(i,k)*PDP(i,k) * RMD/RMO3
+c        print *,'LW: ZOZ*10**6=',ZOZ(i,k)*1000000.
+      ENDDO
+      ENDDO
+cIM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+      CALL LWU(
+     S         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
+     S          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
+     S         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
+     S         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
+     .                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
+     .                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+c
+         PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
+         PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
+c
+cIM attention aux signes !; LWtop >0, LWdn < 0
+         DO k = 1, KFLEV+1
+           plwup(i,k) = ZFLUX(i,1,k)
+           plwup0(i,k) = ZFLUC(i,1,k)
+           plwdn(i,k) = ZFLUX(i,2,k)
+           plwdn0(i,k) = ZFLUC(i,2,k)
+         ENDDO
+      ENDDO
+C     ------------------------------------------------------------------
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+      SUBROUTINE LWU(
+     S               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
+     S               PABCU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+C           TEMPERATURE EFFECTS
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+cIM ctes ds clesphys.h
+c     REAL*8 RCO2
+c     REAL*8 RCH4, RN2O, RCFC11, RCFC12
+#include "clesphys.h"
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PVIEW(KDLON)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+C
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZDUC(KDLON,3*KFLEV+1)
+      REAL*8 ZPHIO(KDLON)
+      REAL*8 ZPSC2(KDLON)
+      REAL*8 ZPSC3(KDLON)
+      REAL*8 ZPSH1(KDLON)
+      REAL*8 ZPSH2(KDLON)
+      REAL*8 ZPSH3(KDLON)
+      REAL*8 ZPSH4(KDLON)
+      REAL*8 ZPSH5(KDLON)
+      REAL*8 ZPSH6(KDLON)
+      REAL*8 ZPSIO(KDLON)
+      REAL*8 ZTCON(KDLON)
+      REAL*8 ZPHM6(KDLON)
+      REAL*8 ZPSM6(KDLON)
+      REAL*8 ZPHN6(KDLON)
+      REAL*8 ZPSN6(KDLON)
+      REAL*8 ZSSIG(KDLON,3*KFLEV+1)
+      REAL*8 ZTAVI(KDLON)
+      REAL*8 ZUAER(KDLON,Ninter)
+      REAL*8 ZXOZ(KDLON)
+      REAL*8 ZXWV(KDLON)
+C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL*8 zfppw, ztx, ztx2, zzably
+      REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL*8 zcac8, zcbc8
+      REAL*8 zalup, zdiff
+c
+      REAL*8 PVGCO2, PVGH2O, PVGO3
+C
+      REAL*8 R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+c
+c Used Data Block:
+c
+      REAL*8 TREF
+      SAVE TREF
+c$OMP THREADPRIVATE(TREF)
+      REAL*8 RT1(2)
+      SAVE RT1
+c$OMP THREADPRIVATE(RT1)
+      REAL*8 RAER(5,5)
+      SAVE RAER
+c$OMP THREADPRIVATE(RAER)
+      REAL*8 AT(8,3), BT(8,3)
+      SAVE AT, BT
+c$OMP THREADPRIVATE(AT, BT)
+      REAL*8 OCT(4)
+      SAVE OCT
+c$OMP THREADPRIVATE(OCT)
+      DATA TREF /250.0/
+      DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
+      DATA RAER / .038520, .037196, .040532, .054934, .038520
+     1          , .12613 , .18313 , .10357 , .064106, .126130
+     2          , .012579, .013649, .018652, .025181, .012579
+     3          , .011890, .016142, .021105, .028908, .011890
+     4          , .013792, .026810, .052203, .066338, .013792 /
+      DATA (AT(1,IR),IR=1,3) /
+     S 0.298199E-02,-.394023E-03,0.319566E-04 /
+      DATA (BT(1,IR),IR=1,3) /
+     S-0.106432E-04,0.660324E-06,0.174356E-06 /
+      DATA (AT(2,IR),IR=1,3) /
+     S 0.143676E-01,0.366501E-02,-.160822E-02 /
+      DATA (BT(2,IR),IR=1,3) /
+     S-0.553979E-04,-.101701E-04,0.920868E-05 /
+      DATA (AT(3,IR),IR=1,3) /
+     S 0.197861E-01,0.315541E-02,-.174547E-02 /
+      DATA (BT(3,IR),IR=1,3) /
+     S-0.877012E-04,0.513302E-04,0.523138E-06 /
+      DATA (AT(4,IR),IR=1,3) /
+     S 0.289560E-01,-.208807E-02,-.121943E-02 /
+      DATA (BT(4,IR),IR=1,3) /
+     S-0.165960E-03,0.157704E-03,-.146427E-04 /
+      DATA (AT(5,IR),IR=1,3) /
+     S 0.103800E-01,0.436296E-02,-.161431E-02 /
+      DATA (BT(5,IR),IR=1,3) /
+     S -.276744E-04,-.327381E-04,0.127646E-04 /
+      DATA (AT(6,IR),IR=1,3) /
+     S 0.868859E-02,-.972752E-03,0.000000E-00 /
+      DATA (BT(6,IR),IR=1,3) /
+     S -.278412E-04,-.713940E-06,0.117469E-05 /
+      DATA (AT(7,IR),IR=1,3) /
+     S 0.250073E-03,0.455875E-03,0.109242E-03 /
+      DATA (BT(7,IR),IR=1,3) /
+     S 0.199846E-05,-.216313E-05,0.175991E-06 /
+      DATA (AT(8,IR),IR=1,3) /
+     S 0.307423E-01,0.110879E-02,-.322172E-03 /
+      DATA (BT(8,IR),IR=1,3) /
+     S-0.108482E-03,0.258096E-05,-.814575E-06 /
+c
+      DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
+C-----------------------------------------------------------------------
+c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+C
+C
+C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+C                ------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
+     S  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+C                --------------------------------------------------
+C
+ 400  CONTINUE
+C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
+     S                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+C                --------------------------------------------------
+C
+ 500  CONTINUE
+C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+C
+C
+C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+C               --------------------------------------------------
+C
+ 510  CONTINUE
+C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
+     S      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
+     S      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
+     S      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+C
+C
+C
+C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+C               --------------------------------------------------
+C
+ 520  CONTINUE
+C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+CMAF      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+CMAF      ZUP   = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
+      ZUP   = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
+     S                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
+     S                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
+     S                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
+     S                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
+     S                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
+     S                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
+     S                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
+     S                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
+     S                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+C
+      PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S               +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+      PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+      PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S               +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+      PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S               +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+C
+      PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+      PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+ 523  CONTINUE
+ 524  CONTINUE
+C
+ 529  CONTINUE
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
+     S                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C     PURPOSE.
+C     --------
+C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+C           SAVING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+C                                          MEMORY)
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER KLIM
+C
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PDT0(KDLON)
+      REAL*8 PEMIS(KDLON)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PTL(KDLON,KFLEV+1)
+      REAL*8 PTAVE(KDLON,KFLEV)
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1)
+C     
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 PBINT(KDLON,KFLEV+1)
+      REAL*8 PBSUI(KDLON)
+      REAL*8 PCTS(KDLON,KFLEV)
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+C
+C-------------------------------------------------------------------------
+C
+C* LOCAL VARIABLES:
+      REAL*8 ZB(KDLON,Ninter,KFLEV+1)
+      REAL*8 ZBSUR(KDLON,Ninter)
+      REAL*8 ZBTOP(KDLON,Ninter)
+      REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL*8 ZGA(KDLON,8,2,KFLEV)
+      REAL*8 ZGB(KDLON,8,2,KFLEV)
+      REAL*8 ZGASUR(KDLON,8,2)
+      REAL*8 ZGBSUR(KDLON,8,2)
+      REAL*8 ZGATOP(KDLON,8,2)
+      REAL*8 ZGBTOP(KDLON,8,2)
+C
+      INTEGER nuaer, ntraer
+C     ------------------------------------------------------------------
+C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB(PDT0,PTAVE,PTL,
+     S          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
+     S          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+C     ------------------------------------------------------------------
+C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV(NUAER,NTRAER, KLIM
+     R  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
+     R  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+C     ------------------------------------------------------------------
+      RETURN
+      END
+      SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
+     R               PBINT,PBSUIN,PCTS,PCNTRB,
+     S               PFLUX)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+C           RADIANCES
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+C PFLUC
+C     ==== OUTPUTS ===
+C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+C                     1  ==>  UPWARD   FLUX TOTAL
+C                     2  ==>  DOWNWARD FLUX TOTAL
+C
+C     METHOD.
+C     -------
+C
+C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+C     CLOUDS
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER klim
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL*8 PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+c
+      REAL*8 PCLDLD(KDLON,KFLEV)
+      REAL*8 PCLDLU(KDLON,KFLEV)
+      REAL*8 PEMIS(KDLON)
+C
+      REAL*8 PFLUX(KDLON,2,KFLEV+1)
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+C
+      REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
+     S  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
+     S  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
+C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL*8 zcfrac
+C     ------------------------------------------------------------------
+C
+C*         1.     INITIALIZATION
+C                 --------------
+C
+ 100  CONTINUE
+C
+      IMAXC = 0
+C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+C
+C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+C                 -------------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+CGM*******
+      IMAXC=KFLEV
+CGM*******
+C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+C                  ---------------------------------------
+C
+      IF (IMAXC.GT.0) THEN
+C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+C
+C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+C                  ------------------------------
+C
+ 200  CONTINUE
+C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+C
+C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+C                  ----------------------------------------------
+C
+ 210  CONTINUE
+C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+C
+C*         2.1.1   ABOVE THE CLOUD
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+C
+C*         2.1.2   BELOW THE CLOUD
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+C
+ 213     CONTINUE
+C
+C
+C*         2.2     CLOUD COVER MATRIX
+C                  ------------------
+C
+C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+C
+ 220  CONTINUE
+C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+C
+C
+C
+C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 240  CONTINUE
+C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+C
+C
+C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 250  CONTINUE
+C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+C
+C
+C
+C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+C                  ----------------------------------------------
+C
+ 300  CONTINUE
+C
+C*         3.1     DOWNWARD FLUXES
+C                  ---------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+C
+      DO 317 JK1 = KFLEV , 1 , -1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+C
+ 317  CONTINUE
+C
+C
+C
+C
+C*         3.2     UPWARD FLUX AT THE SURFACE
+C                  --------------------------
+C
+ 320  CONTINUE
+C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+C
+C
+C
+C*         3.3     UPWARD FLUXES
+C                  -------------
+C
+ 330  CONTINUE
+C
+      DO 337 JK1 = 2 , KFLEV+1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+C
+ 337  CONTINUE
+C
+C
+      END IF
+C
+C
+C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+C
+ 230  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+C
+      RETURN
+      END
+      SUBROUTINE LWB(PDT0,PTAVE,PTL
+     S  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
+     S  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES PLANCK FUNCTIONS
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+C     ==== OUTPUTS ===
+C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C
+C-----------------------------------------------------------------------
+C
+C ARGUMENTS:
+C
+      REAL*8 PDT0(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PTL(KDLON,KFLEV+1)
+C
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+C-------------------------------------------------------------------------
+C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL*8 zdsto1, zdstox, zdst1, zdstx
+c
+C* Quelques parametres:
+      REAL*8 TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL*8 TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+C
+C* Used Data Block:
+      REAL*8 TINTP(11)
+      SAVE TINTP
+c$OMP THREADPRIVATE(TINTP)
+      REAL*8 GA(11,16,3), GB(11,16,3)
+      SAVE GA, GB
+c$OMP THREADPRIVATE(GA, GB)
+      REAL*8 XP(6,6)
+      SAVE XP
+c$OMP THREADPRIVATE(XP)
+c
+      DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+     S             262.5, 275., 287.5, 300., 312.5 /
+C-----------------------------------------------------------------------
+C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+C
+C
+C
+C
+C-- R.D. -- G = - 0.2 SLA
+C
+C
+C----- INTERVAL = 1 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+      DATA (GB( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+      DATA (GA( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+      DATA (GB( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+      DATA (GB( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+      DATA (GA( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+      DATA (GB( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+      DATA (GB( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+      DATA (GA( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+      DATA (GB( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+      DATA (GB( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+      DATA (GA( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+      DATA (GB( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+      DATA (GB( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+      DATA (GA( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+      DATA (GB( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+      DATA (GB( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+      DATA (GA( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+      DATA (GB( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+      DATA (GB( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+      DATA (GA( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+      DATA (GB( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+      DATA (GB( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+      DATA (GA( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+      DATA (GB( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+      DATA (GB( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+      DATA (GA( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+      DATA (GB( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+      DATA (GB(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+      DATA (GA(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+      DATA (GB(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+      DATA (GB(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+      DATA (GA(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+      DATA (GB(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+C
+C
+C
+C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+C
+C
+C
+C
+C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+C
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+      DATA (GB( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+      DATA (GA( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+      DATA (GB( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+      DATA (GB( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+      DATA (GA( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+      DATA (GB( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+      DATA (GB( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+      DATA (GA( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+      DATA (GB( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+      DATA (GB( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+      DATA (GA( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+      DATA (GB( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+      DATA (GB( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+      DATA (GA( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+      DATA (GB( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+      DATA (GB( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+      DATA (GA( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+      DATA (GB( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+      DATA (GB( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+      DATA (GA( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+      DATA (GB( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+      DATA (GB( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+      DATA (GA( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+      DATA (GB( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+      DATA (GB( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+      DATA (GA( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+      DATA (GB( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+      DATA (GB(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+      DATA (GA(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+      DATA (GB(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+      DATA (GB(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+      DATA (GA(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+      DATA (GB(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+C
+C
+C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C
+C--- G = 3.875E-03 ---------------
+C
+C----- INTERVAL = 3 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+      DATA (GB( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+      DATA (GA( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+      DATA (GB( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+      DATA (GB( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+      DATA (GA( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+      DATA (GB( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+      DATA (GB( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+      DATA (GA( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+      DATA (GB( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+      DATA (GB( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+      DATA (GA( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+      DATA (GB( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+      DATA (GB( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+      DATA (GA( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+      DATA (GB( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+      DATA (GB( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+      DATA (GA( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+      DATA (GB( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+      DATA (GB( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+      DATA (GA( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+      DATA (GB( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+      DATA (GB( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+      DATA (GA( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+      DATA (GB( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+      DATA (GB( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+      DATA (GA( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+      DATA (GB( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+      DATA (GB(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+      DATA (GA(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+      DATA (GB(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+      DATA (GB(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+      DATA (GA(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+      DATA (GB(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+C
+C
+C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+C
+C-- G = 3.6E-03
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+      DATA (GB( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+      DATA (GA( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+      DATA (GB( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+      DATA (GB( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+      DATA (GA( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+      DATA (GB( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+      DATA (GB( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+      DATA (GA( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+      DATA (GB( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+      DATA (GB( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+      DATA (GA( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+      DATA (GB( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+      DATA (GB( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+      DATA (GA( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+      DATA (GB( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+      DATA (GB( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+      DATA (GA( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+      DATA (GB( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+      DATA (GB( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+      DATA (GA( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+      DATA (GB( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+      DATA (GB( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+      DATA (GA( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+      DATA (GB( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+      DATA (GB( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+      DATA (GA( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+      DATA (GB( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+      DATA (GB(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+      DATA (GA(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+      DATA (GB(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+      DATA (GB(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+      DATA (GA(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+      DATA (GB(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+C
+C
+C
+C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+C
+C-- WATER VAPOR --- 350 - 500 CM-1
+C
+C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+C
+C----- INTERVAL = 5 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+      DATA (GB( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+      DATA (GA( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+      DATA (GB( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+      DATA (GB( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+      DATA (GA( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+      DATA (GB( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+      DATA (GB( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+      DATA (GA( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+      DATA (GB( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+      DATA (GB( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+      DATA (GA( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+      DATA (GB( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+      DATA (GB( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+      DATA (GA( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+      DATA (GB( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+      DATA (GB( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+      DATA (GA( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+      DATA (GB( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+      DATA (GB( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+      DATA (GA( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+      DATA (GB( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+      DATA (GB( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+      DATA (GA( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+      DATA (GB( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+      DATA (GB( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+      DATA (GA( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+      DATA (GB( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+      DATA (GB(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+      DATA (GA(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+      DATA (GB(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+      DATA (GB(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+      DATA (GA(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+      DATA (GB(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+C
+C
+C
+C
+C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+C--- G = 0.0
+C
+C
+C----- INTERVAL = 6 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+      DATA (GB( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+      DATA (GA( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+      DATA (GB( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+      DATA (GB( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+      DATA (GA( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+      DATA (GB( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+      DATA (GB( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+      DATA (GA( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+      DATA (GB( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+      DATA (GB( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+      DATA (GA( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+      DATA (GB( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+      DATA (GB( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+      DATA (GA( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+      DATA (GB( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+      DATA (GB( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+      DATA (GA( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+      DATA (GB( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+      DATA (GB( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+      DATA (GA( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+      DATA (GB( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+      DATA (GB( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+      DATA (GA( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+      DATA (GB( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+      DATA (GB( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+      DATA (GA( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+      DATA (GB( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+      DATA (GB(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+      DATA (GA(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+      DATA (GB(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+      DATA (GB(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+      DATA (GA(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+      DATA (GB(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C-- END WATER VAPOR
+C
+C
+C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+C
+C
+C
+C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+      DATA (GB( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+      DATA (GA( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+      DATA (GB( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+      DATA (GB( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+      DATA (GA( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+      DATA (GB( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+      DATA (GB( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+      DATA (GA( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+      DATA (GB( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+      DATA (GB( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+      DATA (GA( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+      DATA (GB( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+      DATA (GB( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+      DATA (GA( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+      DATA (GB( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+      DATA (GB( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+      DATA (GA( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+      DATA (GB( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+      DATA (GB( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+      DATA (GA( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+      DATA (GB( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+      DATA (GB( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+      DATA (GA( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+      DATA (GB( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+      DATA (GB( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+      DATA (GA( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+      DATA (GB( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+      DATA (GB(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+      DATA (GA(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+      DATA (GB(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+      DATA (GB(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+      DATA (GA(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+      DATA (GB(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C-- G = 0.0
+C
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+      DATA (GB( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+      DATA (GA( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+      DATA (GB( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+      DATA (GB( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+      DATA (GA( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+      DATA (GB( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+      DATA (GB( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+      DATA (GA( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+      DATA (GB( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+      DATA (GB( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+      DATA (GA( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+      DATA (GB( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+      DATA (GB( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+      DATA (GA( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+      DATA (GB( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+      DATA (GB( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+      DATA (GA( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+      DATA (GB( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+      DATA (GB( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+      DATA (GA( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+      DATA (GB( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+      DATA (GB( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+      DATA (GA( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+      DATA (GB( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+      DATA (GB( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+      DATA (GA( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+      DATA (GB( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+      DATA (GB(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+      DATA (GA(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+      DATA (GB(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+      DATA (GB(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+      DATA (GA(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+      DATA (GB(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+
+C     ------------------------------------------------------------------
+      DATA (( XP(  J,K),J=1,6),       K=1,6) /
+     S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+     S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+     S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+     S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+     S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+     S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+     S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+     S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+     S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+     S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+     S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+     S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+C
+C
+C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+C                  ------------------------------
+C
+ 100  CONTINUE
+C
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+C
+      DO 141 JNU=1,Ninter
+C
+C
+C*         1.1   LEVELS FROM SURFACE TO KFLEV
+C                ----------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C
+C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+C                ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+C
+C
+C*         1.3   GRADIENTS IN SUB-LAYERS
+C                -----------------------
+C
+ 130  CONTINUE
+C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+C
+ 141  CONTINUE
+C
+C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+C                ---------------------------------------------
+C
+ 200  CONTINUE
+C
+C
+ 210  CONTINUE
+C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+C
+ 220  CONTINUE
+C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWV(KUAER,KTRAER, KLIM
+     R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+C           FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+C                      -  THE DISTANT LAYERS
+C                      -  THE BOUNDARY TERMS
+C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+C-----------------------------------------------------------------------
+C LOCAL VARIABLES:
+      REAL*8 ZADJD(KDLON,KFLEV+1)
+      REAL*8 ZADJU(KDLON,KFLEV+1)
+      REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
+      REAL*8 ZDISD(KDLON,KFLEV+1)
+      REAL*8 ZDISU(KDLON,KFLEV+1)
+C
+      INTEGER jk, jl
+C-----------------------------------------------------------------------
+C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C* CONTRIBUTION FROM ADJACENT LAYERS
+C
+      CALL LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+C* CONTRIBUTION FROM DISTANT LAYERS
+C
+      CALL LWVD(KUAER,KTRAER
+     R  , PABCU,ZDBDT,PGA,PGB
+     S  , PCNTRB,ZDISD,ZDISU)
+C
+C* EXCHANGE WITH THE BOUNDARIES
+C
+      CALL LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
+     R  , ZDISD,ZDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
+     R  , PDISD,PDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+C           INTEGRATION
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+C     ATMOSPHERE
+C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZBGND(KDLON)
+      REAL*8 ZFD(KDLON)
+      REAL*8  ZFN10(KDLON)
+      REAL*8 ZFU(KDLON)
+      REAL*8  ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8  ZUU(KDLON,NUA) 
+      REAL*8 ZCNSOL(KDLON)
+      REAL*8 ZCNTOP(KDLON)
+C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL*8 zctstr
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+C                  -----------------------------------
+C
+ 230  CONTINUE
+C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+C
+C
+      CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+C
+ 235  CONTINUE
+C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)
+     1   + PBTOP(JL,2)
+     2   + PBTOP(JL,3)
+     3   + PBTOP(JL,4)
+     4   + PBTOP(JL,5)
+     5   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+C
+C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+C                  ---------------------------------------
+C
+ 240  CONTINUE
+C
+C
+C*         2.4.1   INITIALIZATION
+C                  --------------
+C
+ 2410 CONTINUE
+C
+      JLIM = KFLEV
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+C
+C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+C                  -----------------------------
+C
+ 2420   CONTINUE
+C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+C
+C
+        CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =
+     1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
+     1       *(ZTT1(JL,1)           *ZTT1(JL,10)
+     1       - ZTT (JL,1)           *ZTT (JL,10))
+     2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
+     2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
+     2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
+     3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
+     3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
+     3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
+     4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
+     4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
+     4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
+     5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
+     5       *(ZTT1(JL,3)           *ZTT1(JL,14)
+     5       - ZTT (JL,3)           *ZTT (JL,14))
+     6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
+     6       *(ZTT1(JL,6)           *ZTT1(JL,15)
+     6       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+C
+C
+C*         2.5     EXCHANGE WITH LOWER LIMIT
+C                  -------------------------
+C
+ 250  CONTINUE
+C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
+     S               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)
+     1 +PBSUR(JL,2)
+     2 +PBSUR(JL,3)
+     3 +PBSUR(JL,4)
+     4 +PBSUR(JL,5)
+     5 +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+C
+C
+      CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+C
+C
+ 257  CONTINUE
+C
+C
+C
+C*         2.7     CLEAR-SKY FLUXES
+C                  ----------------
+C
+ 270  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWVD(KUAER,KTRAER
+     S  , PABCU,PDBDT
+     R  , PGA,PGB
+     S  , PCNTRB,PDISD,PDISU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL*8 PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL*8 zww, zdzxdg, zdzxmg
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+C                  ---------------------------------
+C
+ 220  CONTINUE
+C
+C
+C*         2.2.1   DISTANT AND ABOVE LAYERS
+C                  ------------------------
+C
+ 2210 CONTINUE
+C
+C
+C
+C*         2.2.2   FIRST UPPER LEVEL
+C                  -----------------
+C
+ 2220 CONTINUE
+C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+C
+      CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
+     2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+C
+C
+C
+C*         2.2.3   HIGHER UP
+C                  ---------
+C
+ 2230 CONTINUE
+C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+C
+C
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C
+C*         2.2.4   DISTANT AND BELOW LAYERS
+C                  ------------------------
+C
+ 2240 CONTINUE
+C
+C
+C
+C*         2.2.5   FIRST LOWER LEVEL
+C                  -----------------
+C
+ 2250 CONTINUE
+C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+C
+C
+      CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
+     2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+C
+C
+C
+C*         2.2.6   DOWN BELOW
+C                  ----------
+C
+ 2260 CONTINUE
+C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+C
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+C
+C
+ 227  CONTINUE
+ 228  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , PADJD,PADJU,PCNTRB,PDBDT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+C
+C* LOCAL ARRAYS:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8 ZUU(KDLON,NUA)
+C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL*8 zwtr
+c
+C* Data Block:
+c
+      REAL*8 WG1(2)
+      SAVE WG1
+c$OMP THREADPRIVATE(WG1)
+      DATA (WG1(jk),jk=1,2) /1.0, 1.0/
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+C
+C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+C                  ---------------------------------
+C
+ 210  CONTINUE
+C
+      DO 215 JK = 1 , KFLEV
+C
+C*         2.1.1   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+C
+C*         2.1.2   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+C
+ 213  CONTINUE
+C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+C
+ 215  CONTINUE
+C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+C
+      RETURN
+C
+      END
+      SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PUU(KDLON,NUA)
+      REAL*8 PTT(KDLON,NTRA)
+      REAL*8 PGA(KDLON,8,2)
+      REAL*8 PGB(KDLON,8,2)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL*8 zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL*8 zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+c     NEXOTIC=1
+c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER ja, jl
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL*8 zxch4, zych4, zsqh41, zodh41
+      REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL*8 zuu11, zuu12
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
+     S         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radopt.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radopt.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/radopt.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+      LOGICAL LEVOIGT
+      PARAMETER (LEVOIGT=.FALSE.)
+      INTEGER NOVLP
+      PARAMETER (NOVLP=1)
+      INTEGER KAER
+      PARAMETER (KAER=0)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ran0_vec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ran0_vec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ran0_vec.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      subroutine ran0_vec(npoints,idum,ran0)
+
+!     $Id$
+!     Platform independent random number generator from
+!     Numerical Recipies
+!     Mark Webb July 1999
+      
+      implicit none
+
+      integer j,npoints,idum(npoints),IA,IM,IQ,IR,k(npoints)
+      real ran0(npoints),AM
+
+      parameter (IA=16807, IM=2147483647, AM=1.0/IM, IQ=127773, IR=2836)
+      
+c     do j=1,npoints
+c       if (idum(j).eq.0) then
+c     	  write(6,*) 'idum=',idum
+c  write(6,*) 'ZERO seed not allowed'
+c  stop
+c       endif
+c     enddo
+
+      do j=1,npoints
+        k(j)=idum(j)/IQ
+        idum(j)=IA*(idum(j)-k(j)*IQ)-IR*k(j)
+        if (idum(j).lt.0) idum(j)=idum(j)+IM
+        ran0(j)=AM*idum(j)
+      enddo
+
+      end
+      
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/read_pstoke.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/read_pstoke.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/read_pstoke.F	(revision 984)
@@ -0,0 +1,486 @@
+!
+! $Header$
+!
+c
+c
+	subroutine read_pstoke(irec,
+     .   zrec,zklono,zklevo,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   fm_therm,en_therm,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+C******************************************************************************
+C  Frederic HOURDIN, Abderrahmane IDELKADI
+C Lecture des parametres physique stockes online necessaires pour
+C recalculer offline le transport de traceurs sur une grille 2x plus fine que 
+C celle online 
+C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+C******************************************************************************
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	
+	  integer klono,klevo,imo,jmo
+	  parameter (imo=iim/2,jmo=(jjm+1)/2)
+	  parameter(klono=(jmo-1)*imo+2,klevo=llm)
+	  REAL phisfi(klono)
+          REAL phisfi2(imo,jmo+1),airefi2(imo,jmo+1)
+
+          REAL mfu(klono,klevo), mfd(klono,klevo)
+          REAL en_u(klono,klevo), de_u(klono,klevo)
+          REAL en_d(klono,klevo), de_d(klono,klevo)
+          REAL coefh(klono,klevo)
+           REAL fm_therm(klono,klevo),en_therm(klono,klevo)
+
+          REAL mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo)
+          REAL en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo)
+          REAL en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo)
+          REAL coefh2(imo,jmo+1,klevo)
+           REAL fm_therm2(imo,jmo+1,klevo)
+           REAL en_therm2(imo,jmo+1,klevo)
+
+          REAL pl(klevo)
+          integer irec
+          integer xid,yid,zid,tid
+          real zrec,zklono,zklevo,zim,zjm
+          integer ncrec,ncklono,ncklevo,ncim,ncjm
+
+          real airefi(klono)
+          character*20 namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def klono
+c dim de phis??
+	  
+	 
+          REAL frac_impa(klono,klevo), frac_nucl(klono,klevo)
+          REAL frac_impa2(imo,jmo+1,klevo), 
+     .     frac_nucl2(imo,jmo+1,klevo)
+          REAL pyu1(klono), pyv1(klono)
+          REAL pyu12(imo,jmo+1), pyv12(imo,jmo+1)
+          REAL ftsol(klono,nbsrf)
+          REAL psrf(klono,nbsrf) 
+	  REAL ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono)
+          REAL psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono)
+          REAL ftsol12(imo,jmo+1),ftsol22(imo,jmo+1),
+     .     ftsol32(imo,jmo+1),
+     .     ftsol42(imo,jmo+1)
+          REAL psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1),
+     .     psrf42(imo,jmo+1)
+		REAL t(klono,klevo)
+		REAL t2(imo,jmo+1,klevo)	
+	  integer ncidp
+          save ncidp
+		integer varidt
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+          integer varidend,varidded,varidch,varidfi,varidfn
+           integer varidfmth,varidenth
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+          save varidend,varidded,varidch,varidfi,varidfn
+           save varidfmth,varidenth
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+		save varidt
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+c A FAIRE: Es-il necessaire de stocke t?
+	        varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+	
+c abder (pour thermiques)
+             varidfmth=NCVID(ncidp,'fm_th',rcode)
+             print*,'ncidp,varidfmth',ncidp,varidfmth
+
+             varidenth=NCVID(ncidp,'en_th',rcode)
+             print*,'ncidp,varidenth',ncidp,varidenth
+
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,ncklevo)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zklevo=ncklevo
+            zim=ncim
+            zjm=ncjm
+	
+	    zklono=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : zklevo = ', zklevo
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : zklono = ', zklono
+
+c niveaux de pression
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,zklevo,pl)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl)
+#endif
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi)
+
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+       call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=zklevo
+      count(4)=1
+
+
+C *** Lessivage******************************************************
+c frac_impa 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa)
+
+c frac_nucl 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl)
+
+C*** Temperature ******************************************************
+c abder t
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t)
+
+C*** Flux pour le calcul de la convection TIEDTK ***********************
+c mfu
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d)
+
+C **** Coeffecient du mellange turbulent**********************************
+c coefh 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+       call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh)
+
+C*** Flux ascendant et entrant pour les Thermiques************************
+cabder thermiques
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,count,fm_therm2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfmth,start,count,fm_therm2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,fm_therm2,fm_therm)
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,count,en_therm2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenth,start,count,en_therm2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_therm2,en_therm)
+
+C*** Vitesses aux sol ******************************************************
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+c pyu1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1)
+
+c pyv1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1)
+
+C*** Temperature au sol ********************************************
+c ftsol1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1)
+
+c ftsol2
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2)
+
+c ftsol3
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4)
+
+C*** Nature du sol **************************************************
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4)
+	
+          do i = 1,klono
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/read_pstoke0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/read_pstoke0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/read_pstoke0.F	(revision 984)
@@ -0,0 +1,510 @@
+!
+! $Header$
+!
+c
+c
+	subroutine read_pstoke0(irec,
+     .   zrec,zkon,zkev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   fm_therm,en_therm,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+C******************************************************************************
+C  Frederic HOURDIN, Abderrahmane IDELKADI
+C Lecture des parametres physique stockes online necessaires pour
+C recalculer offline le transport des traceurs sur la meme grille que online
+C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+C******************************************************************************
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	  
+	  integer kon,kev,zkon,zkev
+	  parameter(kon=iim*(jjm-1)+2,kev=llm)
+	  REAL phisfi(kon)
+          REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
+
+          REAL mfu(kon,kev), mfd(kon,kev)
+          REAL en_u(kon,kev), de_u(kon,kev)
+          REAL en_d(kon,kev), de_d(kon,kev)
+          REAL coefh(kon,kev)
+
+c abd 25 11 02
+c Thermiques
+	 REAL fm_therm(kon,kev),en_therm(kon,kev)
+		REAL t(kon,kev)
+
+          REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
+          REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
+          REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
+          REAL coefh2(iim,jjm+1,kev)
+		REAL t2(iim,jjm+1,kev)
+c Thermiques
+	 REAL fm_therm2(iim,jjm+1,kev)
+         REAL en_therm2(iim,jjm+1,kev)       
+
+          REAL pl(kev)
+          integer irec
+          integer xid,yid,zid,tid
+          integer zrec,zim,zjm
+          integer ncrec,nckon,nckev,ncim,ncjm
+
+          real airefi(kon)
+          character*20 namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def kon
+c dim de phis??
+
+          REAL frac_impa(kon,kev), frac_nucl(kon,kev)
+          REAL frac_impa2(iim,jjm+1,kev), 
+     .     frac_nucl2(iim,jjm+1,kev)
+          REAL pyu1(kon), pyv1(kon)
+          REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1)
+          REAL ftsol(kon,nbsrf)
+          REAL psrf(kon,nbsrf) 
+	  REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
+          REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
+          REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
+     .     ftsol32(iim,jjm+1),
+     .     ftsol42(iim,jjm+1)
+          REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
+     .     psrf42(iim,jjm+1)
+	
+	  integer ncidp
+          save ncidp
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+		integer varidt
+          integer varidend,varidded,varidch,varidfi,varidfn
+c therm
+	  integer varidfmth,varidenth
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+		save varidt
+          save varidend,varidded,varidch,varidfi,varidfn
+c therm
+	   save varidfmth,varidenth
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+                varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+
+c Thermiques
+            varidfmth=NCVID(ncidp,'fm_th',rcode)
+            print*,'ncidp,varidfmth',ncidp,varidfmth
+
+            varidenth=NCVID(ncidp,'en_th',rcode)
+            print*,'ncidp,varidenth',ncidp,varidenth
+	
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,nckev)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zkev=nckev
+            zim=ncim
+            zjm=ncjm
+	
+	    zkon=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : kev = ', zkev
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : kon = ', zkon
+
+c niveaux de pression
+
+            status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c 
+C**** Geopotentiel au sol ***************************************
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
+
+C**** Aires des mails aux sol ************************************
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=kev
+      count(4)=1
+
+C**** Temperature ********************************************
+cA FAIRE : Es-ce necessaire ?
+
+c abder t
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
+
+C**** Flux pour la convection (Tiedtk) ********************************************
+c mfu
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
+
+C**** Coefficient de mellange turbulent *******************************************
+c coefh 
+	print*,'LECTURE de coefh a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
+c      call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ   ')
+c      call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ   ')
+
+C**** Flux ascendants et entrant dans le thermique **********************************
+cThermiques
+       print*,'LECTURE de fm_therm a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,
+     .                         count,fm_therm2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidfmth,start,
+     .                         count,fm_therm2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm)
+       print*,'LECTURE de en_therm a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,
+     .                          count,en_therm2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidenth,start,
+     .                          count,en_therm2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm)
+
+C**** Coefficients de lessivage *******************************************
+c frac_impa
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
+
+c frac_nucl
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
+
+C**** Vents aux sol ********************************************
+
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+
+c pyu1
+	print*,'LECTURE de yu1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
+
+c pyv1
+        print*,'LECTURE de yv1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
+
+C**** Temerature au sol ********************************************
+c ftsol1
+        print*,'LECTURE de ftsol1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
+
+c ftsol2
+        print*,'LECTURE de ftsol2 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
+
+c ftsol3
+	 print*,'LECTURE de ftsol3 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
+
+C**** Nature sol ********************************************
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
+	
+          do i = 1,kon
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+c test abderr
+c	print*,'Dans read_pstoke psrf3 =',psrf3(i),i
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/readsulfate.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/readsulfate.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/readsulfate.F	(revision 984)
@@ -0,0 +1,640 @@
+!
+! $Header$
+!
+      SUBROUTINE readsulfate (r_day, first, sulfate_p)
+      USE dimphy, ONLY : klev
+      USE mod_grid_phy_lmdz, klon=>klon_glo
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+      
+c Content: 
+c --------
+c This routine reads in monthly mean values of sulfate aerosols and 
+c returns a linearly interpolated dayly-mean field.      
+c 
+c
+c Author:
+c -------
+c Johannes Quaas (quaas@lmd.jussieu.fr) 
+c 26/04/01
+c
+c Modifications:
+c --------------
+c 21/06/01: Make integrations of more than one year possible ;-)     
+c           ATTENTION!! runs are supposed to start with Jan, 1. 1930
+c                       (rday=1)      
+c
+c 27/06/01: Correction: The model always has 360 days per year!
+c 27/06/01: SO4 concentration rather than mixing ratio      
+c 27/06/01: 10yr-mean-values to interpolate     
+c 20/08/01: Correct the error through integer-values in interpolations      
+c 21/08/01: Introduce flag to read in just one decade
+c      
+c Include-files:
+c --------------     
+#include "YOMCST.h"
+#include "chem.h"      
+#include "dimensions.h"      
+cym#include "dimphy.h"      
+#include "temps.h"      
+c 
+c Input:
+c ------
+      REAL  r_day                   ! Day of integration
+      LOGICAL first                 ! First timestep 
+                                    ! (and therefore initialization necessary)
+c      
+c Output:      
+c -------     
+      REAL  sulfate_p(klon_omp,klev)
+      REAL  sulfate (klon, klev)  ! Mass of sulfate (monthly mean data, 
+                                  !  from file) [ug SO4/m3]
+c      
+c Local Variables:
+c ----------------      
+      INTEGER i, ig, k, it
+      INTEGER j, iday, ny, iyr, iyr1, iyr2
+      parameter (ny=jjm+1)
+      
+CJLD      INTEGER idec1, idec2 ! The two decadal data read ini
+      CHARACTER*4 cyear
+      
+      INTEGER im, day1, day2, im2
+      REAL so4_1(iim, jjm+1, klev, 12)
+      REAL so4_2(iim, jjm+1, klev, 12)   ! The sulfate distributions
+      
+      REAL, allocatable,save :: so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: so4_out(:, :)
+c$OMP THREADPRIVATE(so4,so4_out)
+      
+      LOGICAL lnewday 
+      LOGICAL lonlyone
+      PARAMETER (lonlyone=.FALSE.)
+      logical,save :: first2=.true.
+c$OMP THREADPRIVATE(first2)
+
+c$OMP MASTER
+      if (first2) then
+     
+        allocate( so4(klon, klev, 12) )
+        allocate( so4_out(klon, klev))
+        first2=.false.
+	
+      endif
+
+      if (is_mpi_root) then
+            
+      iday = INT(r_day) 
+      
+      ! Get the year of the run
+      iyr  = iday/360
+      
+      ! Get the day of the actual year:
+      iday = iday-iyr*360
+      
+      ! 0.02 is about 0.5/24, namly less than half an hour
+      lnewday = (r_day-FLOAT(iday).LT.0.02)
+      
+! ---------------------------------------------
+! All has to be done only, if a new day begins!       
+! ---------------------------------------------
+
+      IF (lnewday.OR.first) THEN
+         
+      im = iday/30 +1 ! the actual month
+      ! annee_ref is the initial year (defined in temps.h)
+      iyr = iyr + annee_ref
+      
+      ! Do I have to read new data? (Is this the first day of a year?)
+      IF (first.OR.iday.EQ.1.) THEN 
+      ! Initialize values
+      DO it=1,12
+      DO k=1,klev
+         DO i=1,klon
+            so4(i,k,it)=0.
+         ENDDO
+      ENDDO
+      ENDDO
+
+
+      IF (iyr .lt. 1850) THEN
+         cyear='.nat'
+         WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+         CALL getso4fromfile(cyear, so4_1)
+      ELSE IF (iyr .ge. 2100) THEN
+         cyear='2100'
+         WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+         CALL getso4fromfile(cyear, so4_1)
+      ELSE
+
+      	! Read in data:
+      ! a) from actual 10-yr-period
+
+      IF (iyr.LT.1900) THEN
+         iyr1 = 1850
+         iyr2 = 1900
+      ELSE IF (iyr.ge.1900.and.iyr.lt.1920) THEN
+         iyr1 = 1900
+         iyr2 = 1920
+      ELSE 
+         iyr1 = INT(iyr/10)*10
+         iyr2 = INT(1+iyr/10)*10
+      ENDIF
+      WRITE(cyear,'(I4)') iyr1
+      WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+      CALL getso4fromfile(cyear, so4_1)
+
+      
+      ! If to read two decades:
+      IF (.NOT.lonlyone) THEN
+         
+      ! b) from the next following one
+      WRITE(cyear,'(I4)') iyr2
+      WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+      CALL getso4fromfile(cyear, so4_2)
+
+      ENDIF
+ 
+      ! Interpolate linarily to the actual year:
+      DO it=1,12
+         DO k=1,klev
+            DO j=1,jjm
+               DO i=1,iim
+                  so4_1(i,j,k,it)=so4_1(i,j,k,it)
+     .                 - FLOAT(iyr-iyr1)/FLOAT(iyr2-iyr1)
+     .                 * (so4_1(i,j,k,it) - so4_2(i,j,k,it))
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDDO                           
+      
+      ENDIF !lonlyone
+      
+      ! Transform the horizontal 2D-field into the physics-field
+      ! (Also the levels and the latitudes have to be inversed)
+      
+      DO it=1,12
+      DO k=1, klev         
+         ! a) at the poles, use the zonal mean:
+         DO i=1,iim
+            ! North pole
+            so4(1,k,it)=so4(1,k,it)+so4_1(i,jjm+1,klev+1-k,it)
+            ! South pole
+            so4(klon,k,it)=so4(klon,k,it)+so4_1(i,1,klev+1-k,it)
+         ENDDO
+         so4(1,k,it)=so4(1,k,it)/FLOAT(iim)
+         so4(klon,k,it)=so4(klon,k,it)/FLOAT(iim)
+      
+         ! b) the values between the poles:
+         ig=1
+         DO j=2,jjm
+            DO i=1,iim
+               ig=ig+1
+               if (ig.gt.klon) write (*,*) 'shit'
+               so4(ig,k,it) = so4_1(i,jjm+1+1-j,klev+1-k,it)
+            ENDDO
+         ENDDO
+         IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)'
+      ENDDO ! Loop over k (vertical)
+      ENDDO ! Loop over it (months)
+               
+
+      ENDIF ! Had to read new data?
+      
+      
+      ! Interpolate to actual day:
+      IF (iday.LT.im*30-15) THEN         
+         ! in the first half of the month use month before and actual month
+         im2=im-1
+         day2 = im2*30-15
+         day1 = im2*30+15
+         IF (im2.LE.0) THEN 
+            ! the month is january, thus the month before december
+            im2=12
+         ENDIF
+         DO k=1,klev
+            DO i=1,klon
+               sulfate(i,k) = so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (so4(i,k,im2) - so4(i,k,im))
+               IF (sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (so4(i,k,im2) - so4(i,k,im).LT.0.)
+     . write(*,*) 'so4(i,k,im2) - so4(i,k,im)',
+     . so4(i,k,im2) - so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ELSE 
+         ! the second half of the month
+         im2=im+1
+         IF (im2.GT.12) THEN
+            ! the month is december, the following thus january
+            im2=1
+         ENDIF
+         day2 = im*30-15
+         day1 = im*30+15
+         DO k=1,klev
+            DO i=1,klon
+               sulfate(i,k) = so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (so4(i,k,im2) - so4(i,k,im))
+               IF (sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (so4(i,k,im2) - so4(i,k,im).LT.0.)
+     . write(*,*) 'so4(i,k,im2) - so4(i,k,im)',
+     . so4(i,k,im2) - so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+
+      
+CJLD      ! The sulfate concentration [molec cm-3] is read in. 
+CJLD      ! Convert it into mass [ug SO4/m3]
+CJLD      ! masse_so4 in [g/mol], n_avogadro in [molec/mol]
+      ! The sulfate mass [ug SO4/m3] is read in. 
+      DO k=1,klev
+         DO i=1,klon
+CJLD            sulfate(i,k) = sulfate(i,k)*masse_so4
+CJLD     .           /n_avogadro*1.e+12
+            so4_out(i,k) = sulfate(i,k)
+            IF (so4_out(i,k).LT.0) 
+     .          stop 'WAS SOLL DER SCHEISS ? '
+         ENDDO
+      ENDDO
+      ELSE ! if no new day, use old data:
+      DO k=1,klev
+         DO i=1,klon
+            sulfate(i,k) = so4_out(i,k)
+            IF (so4_out(i,k).LT.0) 
+     .          stop 'WAS SOLL DER SCHEISS ? '
+         ENDDO
+      ENDDO
+         
+
+      ENDIF ! Did I have to do anything (was it a new day?)
+
+      endif   ! phy_rank==0
+      
+c$OMP END MASTER
+      call Scatter(sulfate,sulfate_p)            
+
+      RETURN
+      END
+
+      
+      
+      
+      
+c-----------------------------------------------------------------------------
+c Read in /calculate pre-industrial values of sulfate      
+c-----------------------------------------------------------------------------
+      
+      SUBROUTINE readsulfate_preind (r_day, first, pi_sulfate_p)
+      USE dimphy, ONLY : klev
+      USE mod_grid_phy_lmdz, klon=>klon_glo
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+      
+c Content: 
+c --------
+c This routine reads in monthly mean values of sulfate aerosols and 
+c returns a linearly interpolated dayly-mean field.      
+c 
+c It does so for the preindustriel values of the sulfate, to a large part
+c analogous to the routine readsulfate above.      
+c
+c Only Pb: Variables must be saved and don t have to be overwritten!
+c      
+c Author:
+c -------
+c Johannes Quaas (quaas@lmd.jussieu.fr) 
+c 26/06/01
+c
+c Modifications:
+c --------------
+c see above 
+c      
+c Include-files:
+c --------------     
+#include "YOMCST.h"
+#include "chem.h"      
+#include "dimensions.h"      
+#include "temps.h"      
+c 
+c Input:
+c ------
+      REAL  r_day                   ! Day of integration
+      LOGICAL first                 ! First timestep 
+                                    ! (and therefore initialization necessary)
+c      
+c Output:      
+c -------     
+      REAL  pi_sulfate_p (klon_omp, klev)  
+                                 
+      REAL  pi_sulfate (klon, klev)  ! Number conc. sulfate (monthly mean data, 
+                                  !  from fil
+c      
+c Local Variables:
+c ----------------      
+      INTEGER i, ig, k, it
+      INTEGER j, iday, ny, iyr
+      parameter (ny=jjm+1)
+      
+      INTEGER im, day1, day2, im2
+      REAL pi_so4_1(iim, jjm+1, klev, 12)
+
+      REAL, allocatable,save :: pi_so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: pi_so4_out(:, :)
+c$OMP THREADPRIVATE(pi_so4,pi_so4_out)            
+      
+      CHARACTER*4 cyear
+      LOGICAL lnewday
+      logical,save :: first2=.true.
+c$OMP THREADPRIVATE(first2)
+
+c$OMP MASTER
+      if (first2) then
+     
+        allocate( pi_so4(klon, klev, 12) )
+        allocate( pi_so4_out(klon, klev))
+        first2=.false.
+	
+      endif
+
+      if (is_mpi_root) then
+    
+      
+
+      iday = INT(r_day) 
+      
+      ! Get the year of the run
+      iyr  = iday/360
+      
+      ! Get the day of the actual year:
+      iday = iday-iyr*360
+      
+      ! 0.02 is about 0.5/24, namly less than half an hour
+      lnewday = (r_day-FLOAT(iday).LT.0.02)
+      
+! ---------------------------------------------
+! All has to be done only, if a new day begins!       
+! ---------------------------------------------
+
+      IF (lnewday.OR.first) THEN
+         
+      im = iday/30 +1 ! the actual month
+      
+      ! annee_ref is the initial year (defined in temps.h)
+      iyr = iyr + annee_ref      
+      
+      
+      IF (first) THEN
+         cyear='.nat'
+         CALL getso4fromfile(cyear,pi_so4_1)
+
+               ! Transform the horizontal 2D-field into the physics-field
+               ! (Also the levels and the latitudes have to be inversed)
+
+         ! Initialize field
+         DO it=1,12
+            DO k=1,klev
+               DO i=1,klon
+                  pi_so4(i,k,it)=0.
+               ENDDO
+            ENDDO
+         ENDDO
+         
+         write (*,*) 'preind: finished reading', FLOAT(iim)
+      DO it=1,12
+      DO k=1, klev         
+         ! a) at the poles, use the zonal mean:
+         DO i=1,iim
+            ! North pole
+            pi_so4(1,k,it)=pi_so4(1,k,it)+pi_so4_1(i,jjm+1,klev+1-k,it)
+            ! South pole
+           pi_so4(klon,k,it)=pi_so4(klon,k,it)+pi_so4_1(i,1,klev+1-k,it)
+         ENDDO
+         pi_so4(1,k,it)=pi_so4(1,k,it)/FLOAT(iim)
+         pi_so4(klon,k,it)=pi_so4(klon,k,it)/FLOAT(iim)
+      
+         ! b) the values between the poles:
+         ig=1
+         DO j=2,jjm
+            DO i=1,iim
+               ig=ig+1
+               if (ig.gt.klon) write (*,*) 'shit'
+               pi_so4(ig,k,it) = pi_so4_1(i,jjm+1+1-j,klev+1-k,it)
+            ENDDO
+         ENDDO
+         IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)'
+      ENDDO ! Loop over k (vertical)
+      ENDDO ! Loop over it (months)
+
+      ENDIF                     ! Had to read new data?
+      
+      
+      ! Interpolate to actual day:
+      IF (iday.LT.im*30-15) THEN         
+         ! in the first half of the month use month before and actual month
+         im2=im-1
+         day1 = im2*30+15
+         day2 = im2*30-15
+         IF (im2.LE.0) THEN 
+            ! the month is january, thus the month before december
+            im2=12
+         ENDIF
+         DO k=1,klev
+            DO i=1,klon
+               pi_sulfate(i,k) = pi_so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (pi_so4(i,k,im2) - pi_so4(i,k,im))
+               IF (pi_sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.)
+     . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)',
+     . pi_so4(i,k,im2) - pi_so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'pi_sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ELSE 
+         ! the second half of the month
+         im2=im+1
+         day1 = im*30+15
+         IF (im2.GT.12) THEN
+            ! the month is december, the following thus january
+            im2=1
+         ENDIF
+         day2 = im*30-15
+         
+         DO k=1,klev
+            DO i=1,klon
+               pi_sulfate(i,k) = pi_so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (pi_so4(i,k,im2) - pi_so4(i,k,im))
+               IF (pi_sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.)
+     . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)',
+     . pi_so4(i,k,im2) - pi_so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'pi_sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+
+      
+CJLD      ! The sulfate concentration [molec cm-3] is read in. 
+CJLD      ! Convert it into mass [ug SO4/m3]
+CJLD      ! masse_so4 in [g/mol], n_avogadro in [molec/mol]
+      DO k=1,klev
+         DO i=1,klon
+CJLD            pi_sulfate(i,k) = pi_sulfate(i,k)*masse_so4
+CJLD     .           /n_avogadro*1.e+12
+            pi_so4_out(i,k) = pi_sulfate(i,k)
+         ENDDO
+      ENDDO
+      
+      ELSE ! If no new day, use old data:
+      DO k=1,klev
+         DO i=1,klon
+            pi_sulfate(i,k) = pi_so4_out(i,k)            
+         ENDDO
+      ENDDO
+         
+
+      ENDIF ! Was this the beginning of a new day?
+
+      endif   ! is_mpi_root==0
+      
+c$OMP END MASTER
+      call Scatter(pi_sulfate,pi_sulfate_p)            
+
+      RETURN
+      END
+
+      
+      
+      
+      
+      
+      
+      
+      
+      
+c-----------------------------------------------------------------------------
+c Routine for reading SO4 data from files
+c-----------------------------------------------------------------------------
+            
+
+      SUBROUTINE getso4fromfile (cyr, so4)
+#include "netcdf.inc"
+#include "dimensions.h"      
+#include "dimphy.h"
+      CHARACTER*15 fname
+      CHARACTER*4 cyr
+      
+      CHARACTER*6 cvar
+      INTEGER START(3), COUNT(3)
+      INTEGER  STATUS, NCID, VARID
+      INTEGER imth, i, j, k, ny
+      PARAMETER (ny=jjm+1)
+      
+            
+      REAL so4mth(iim, ny, klev)
+      REAL so4(iim, ny, klev, 12)
+
+ 
+      fname = 'so4.run'//cyr//'.cdf'
+
+      write (*,*) 'reading ', fname
+      STATUS = NF_OPEN (fname, NF_NOWRITE, NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in open ',status
+            
+      DO imth=1, 12
+         IF (imth.eq.1) THEN
+            cvar='SO4JAN'
+         ELSEIF (imth.eq.2) THEN
+            cvar='SO4FEB'
+         ELSEIF (imth.eq.3) THEN
+            cvar='SO4MAR'
+         ELSEIF (imth.eq.4) THEN
+            cvar='SO4APR'
+         ELSEIF (imth.eq.5) THEN
+            cvar='SO4MAY'
+         ELSEIF (imth.eq.6) THEN
+            cvar='SO4JUN'
+         ELSEIF (imth.eq.7) THEN
+            cvar='SO4JUL'
+         ELSEIF (imth.eq.8) THEN
+            cvar='SO4AUG'
+         ELSEIF (imth.eq.9) THEN
+            cvar='SO4SEP'
+         ELSEIF (imth.eq.10) THEN
+            cvar='SO4OCT'
+         ELSEIF (imth.eq.11) THEN
+            cvar='SO4NOV'
+         ELSEIF (imth.eq.12) THEN
+            cvar='SO4DEC'
+         ENDIF
+         start(1)=1
+         start(2)=1
+         start(3)=1
+         count(1)=iim
+         count(2)=ny
+         count(3)=klev
+c         write(*,*) 'here i am'
+         STATUS = NF_INQ_VARID (NCID, cvar, VARID)
+         write (*,*) ncid,imth,cvar, varid
+
+         IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read ',status      
+
+#ifdef NC_DOUBLE
+         status = NF_GET_VARA_DOUBLE(NCID, VARID, START, COUNT, so4mth)
+#else
+         status = NF_GET_VARA_REAL(NCID, VARID, START, COUNT, so4mth)
+#endif
+         IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read data',status
+         
+         DO k=1,klev
+            DO j=1,jjm+1
+               DO i=1,iim
+                  IF (so4mth(i,j,k).LT.0.) then
+                     write(*,*) 'this is shit'
+                     write(*,*) 'so4(',i,j,k,') =',so4mth(i,j,k)
+                  endif
+                  so4(i,j,k,imth)=so4mth(i,j,k)
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDDO
+      
+      STATUS = NF_CLOSE(NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in closing file',status
+
+
+      END ! subroutine getso4fromfile
+      
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/regdim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/regdim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/regdim.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      INTEGER i1_deb, i1_fin
+      INTEGER i2_deb, i2_fin
+ccc      PARAMETER (i1_deb=21, i1_fin=40)
+ccc      PARAMETER (i2_deb=41, i2_fin=44)
+cccc      PARAMETER (i1_deb=47, i1_fin=77)
+cccc      PARAMETER (i2_deb=78, i2_fin=79)
+      PARAMETER (i1_deb=16, i1_fin=30)
+      PARAMETER (i2_deb=31, i2_fin=33)
+c
+      INTEGER j_deb, j_fin
+ccc      PARAMETER (j_deb=29, j_fin=61)
+cccc      PARAMETER (j_deb=21, j_fin=51)
+      PARAMETER (j_deb=18, j_fin=39)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/screenc.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/screenc.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/screenc.F90	(revision 984)
@@ -0,0 +1,84 @@
+!
+! $Header$
+!
+      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, rugos, psol, &
+                         ustar, testar, qstar, okri, ri1, &
+                         pref, delu, delte, delq)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
+!
+      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
+!-----------------------------------------------------------------------
+      include "YOMCST.h"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+      CALL coefcdrag (klon, knon, nsrf, zxli, &
+                    speed, temp, q_zref, gref, &
+                    psol, ts, qsurf, rugos, &
+                    okri, ri1, &
+                    cdram, cdrah, cdran, zri1, &
+                    pref)
+!
+      DO i = 1, knon
+        delu(i) = ustar(i)/sqrt(cdram(i))
+        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
+                   cdrah(i)
+        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
+                  cdrah(i)
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screenc
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/screenp.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/screenp.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/screenp.F90	(revision 984)
@@ -0,0 +1,108 @@
+!
+! $Header$
+!
+      SUBROUTINE screenp(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, lmon, &
+     &                   ustar, testar, qstar, zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! lmon----input-R- longueur de Monin-Obukov
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+        IF (lmon(i).GE.0.) THEN
+!
+! STABLE CASE
+!
+          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0) THEN
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 *(zref - rugos(i))/lmon(i)))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) + &
+                       min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+            delq(i) = (qstar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+          ELSE
+            delu(i)  = 0.1 * speed(i)
+            delte(i) = 0.1 * (tair(i) - ts(i) )
+            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ELSE  
+!
+! UNSTABLE CASE
+!
+          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
+            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
+            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) & 
+                      - 2.*log(0.5*(1. + xtmp)) &
+                      + 2.*log(0.5*(1. + xtmp0)) &
+                      - log(0.5*(1. + xtmp*xtmp)) &
+                      + log(0.5*(1. + xtmp0*xtmp0)) &
+                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+            delq(i)  = (qstar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+          ELSE
+            delu(i)  = 0.5 * speed(i)
+            delte(i) = 0.5 * (tair(i) - ts(i) )
+            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenp
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/soil.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/soil.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/soil.F	(revision 984)
@@ -0,0 +1,272 @@
+!
+! $Header$
+!
+      SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, ptsoil,
+     s          pcapcal, pfluxgrd)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  Frederic Hourdin     30/01/92
+c   -------
+c
+c   objet:  computation of : the soil temperature evolution
+c   ------                   the surfacic heat capacity "Capcal"
+c                            the surface conduction flux pcapcal
+c
+c
+c   Method: implicit time integration
+c   -------
+c   Consecutive ground temperatures are related by:
+c           T(k+1) = C(k) + D(k)*T(k)  (1)
+c   the coefficients C and D are computed at the t-dt time-step.
+c   Routine structure:
+c   1)new temperatures are computed  using (1)
+c   2)C and D coefficients are computed from the new temperature
+c     profile for the t+dt time-step
+c   3)the coefficients A and B are computed where the diffusive
+c     fluxes at the t+dt time-step is given by
+c            Fdiff = A + B Ts(t+dt)
+c     or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
+c            with F0 = A + B (Ts(t))
+c                 Capcal = B*dt
+c           
+c   Interface:
+c   ----------
+c
+c   Arguments:
+c   ----------
+c   ptimestep            physical timestep (s)
+c   indice               sub-surface index
+c   snow(klon,nbsrf)     snow
+c   ptsrf(klon)          surface temperature at time-step t (K)
+c   ptsoil(klon,nsoilmx) temperature inside the ground (K)
+c   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
+c   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
+c   
+c=======================================================================
+c   declarations:
+c   -------------
+
+cym#include "dimensions.h"
+#include "YOMCST.h"
+cym#include "dimphy.h"
+#include "dimsoil.h"
+#include "indicesol.h"
+
+c-----------------------------------------------------------------------
+c  arguments
+c  ---------
+
+      REAL ptimestep
+      INTEGER indice, knon
+      REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon)
+      REAL pcapcal(klon),pfluxgrd(klon)
+
+c-----------------------------------------------------------------------
+c  local arrays
+c  ------------
+
+      INTEGER ig,jk
+c@$$      REAL zdz2(nsoilmx),z1(klon)
+      REAL zdz2(nsoilmx),z1(klon,nbsrf)
+      REAL,SAVE :: min_period,dalph_soil
+c$OMP THREADPRIVATE( min_period,dalph_soil)     
+      REAL ztherm_i(klon)
+
+c   local saved variables:
+c   ----------------------
+      REAL dz1(nsoilmx),dz2(nsoilmx)
+c@$$          REAL zc(klon,nsoilmx),zd(klon,nsoilmx)
+cym      REAL zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf)
+      REAL,ALLOCATABLE,SAVE ::  zc(:,:,:),zd(:,:,:)
+c$OMP THREADPRIVATE(zc,zd)
+      REAL lambda
+cym      SAVE dz1,dz2,zc,zd,lambda
+      SAVE dz1,dz2,lambda
+c$OMP THREADPRIVATE(dz1,dz2,lambda)
+      LOGICAL firstcall, firstsurf(nbsrf)
+      SAVE firstcall, firstsurf
+c$OMP THREADPRIVATE(firstcall, firstsurf)
+      REAL isol,isno,iice
+      SAVE isol,isno,iice
+c$OMP THREADPRIVATE(isol,isno,iice)
+      DATA firstcall/.true./
+      DATA firstsurf/.TRUE.,.TRUE.,.TRUE.,.TRUE./
+
+      DATA isol,isno,iice/2000.,2000.,2000./
+      LOGICAL,SAVE :: First=.true.
+c$OMP THREADPRIVATE(First)
+c-----------------------------------------------------------------------
+c   Depthts:
+c   --------
+
+      REAL fz,rk,fz1,rk1,rk2
+      fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
+      pfluxgrd(:) = 0.
+c   calcul de l'inertie thermique a partir de la variable rnat.
+c   on initialise a iice meme au-dessus d'un point de mer au cas 
+c   ou le point de mer devienne point de glace au pas suivant
+c   on corrige si on a un point de terre avec ou sans glace
+c
+      IF (first) THEN
+        allocate(zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf))
+	first=.false.
+      ENDIF
+      
+      IF (indice.EQ.is_sic) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = iice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_lic) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = iice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_ter) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = isol
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_oce) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = iice
+         ENDDO
+      ELSE
+         PRINT*, "valeur d indice non prevue", indice
+         CALL abort
+      ENDIF
+
+
+c@$$      IF (firstcall) THEN
+      IF (firstsurf(indice)) THEN 
+
+c-----------------------------------------------------------------------
+c   ground levels 
+c   grnd=z/l where l is the skin depth of the diurnal cycle:
+c   --------------------------------------------------------
+
+         min_period=1800. ! en secondes
+         dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
+c$OMP MASTER
+         IF (is_mpi_root) THEN
+         OPEN(99,file='soil.def',status='old',form='formatted',err=9999)
+         READ(99,*) min_period
+         READ(99,*) dalph_soil
+         PRINT*,'Discretization for the soil model'
+         PRINT*,'First level e-folding depth',min_period,
+     s   '   dalph',dalph_soil
+         CLOSE(99)
+9999     CONTINUE
+         ENDIF  ! is_mpi_root
+c$OMP END MASTER
+         CALL bcast(min_period)
+	 CALL bcast(dalph_soil)
+
+c   la premiere couche represente un dixieme de cycle diurne
+         fz1=sqrt(min_period/3.14)
+
+         DO jk=1,nsoilmx
+            rk1=jk
+            rk2=jk-1
+            dz2(jk)=fz(rk1)-fz(rk2)
+         ENDDO
+         DO jk=1,nsoilmx-1
+            rk1=jk+.5
+            rk2=jk-.5
+            dz1(jk)=1./(fz(rk1)-fz(rk2))
+         ENDDO
+         lambda=fz(.5)*dz1(1)
+         PRINT*,'full layers, intermediate layers (seconds)'
+         DO jk=1,nsoilmx
+            rk=jk
+            rk1=jk+.5
+            rk2=jk-.5
+            PRINT *,'fz=',
+     .               fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
+         ENDDO
+C PB
+         firstsurf(indice) = .FALSE. 
+c@$$         firstcall =.false.
+
+c   Initialisations:
+c   ----------------
+
+      ELSE   !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the soil temperatures using the Cgrd and Dgrd
+c  coefficient computed at the previous time-step:
+c  -----------------------------------------------
+
+c    surface temperature
+         DO ig=1,knon
+            ptsoil(ig,1)=(lambda*zc(ig,1,indice)+ptsrf(ig))/
+     s      (lambda*(1.-zd(ig,1,indice))+1.)
+         ENDDO
+
+c   other temperatures
+         DO jk=1,nsoilmx-1
+            DO ig=1,knon
+               ptsoil(ig,jk+1)=zc(ig,jk,indice)+zd(ig,jk,indice)
+     $            *ptsoil(ig,jk)
+            ENDDO
+         ENDDO
+
+      ENDIF !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the Cgrd and Dgrd coefficient for the next step:
+c   ---------------------------------------------------------------
+
+c@$$  PB ajout pour cas glace de mer
+      IF (indice .EQ. is_sic) THEN
+          DO ig = 1 , knon
+            ptsoil(ig,nsoilmx) = RTT - 1.8
+          END DO 
+      ENDIF 
+
+      DO jk=1,nsoilmx
+         zdz2(jk)=dz2(jk)/ptimestep
+      ENDDO
+
+      DO ig=1,knon
+         z1(ig,indice)=zdz2(nsoilmx)+dz1(nsoilmx-1)
+         zc(ig,nsoilmx-1,indice)=
+     $       zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig,indice)
+         zd(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1(ig,indice)
+      ENDDO
+
+      DO jk=nsoilmx-1,2,-1
+         DO ig=1,knon
+            z1(ig,indice)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk)
+     $         *(1.-zd(ig,jk,indice)))
+            zc(ig,jk-1,indice)=
+     s      (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk,indice))
+     $          *z1(ig,indice)
+            zd(ig,jk-1,indice)=dz1(jk-1)*z1(ig,indice)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   computation of the surface diffusive flux from ground and
+c   calorific capacity of the ground:
+c   ---------------------------------
+
+      DO ig=1,knon
+         pfluxgrd(ig)=ztherm_i(ig)*dz1(1)*
+     s   (zc(ig,1,indice)+(zd(ig,1,indice)-1.)*ptsoil(ig,1))
+         pcapcal(ig)=ztherm_i(ig)*
+     s   (dz2(1)+ptimestep*(1.-zd(ig,1,indice))*dz1(1))
+         z1(ig,indice)=lambda*(1.-zd(ig,1,indice))+1.
+         pcapcal(ig)=pcapcal(ig)/z1(ig,indice)
+         pfluxgrd(ig) = pfluxgrd(ig)
+     s   + pcapcal(ig) * (ptsoil(ig,1) * z1(ig,indice)
+     $       - lambda * zc(ig,1,indice)
+     $       - ptsrf(ig))
+     s   /ptimestep
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/stdlevvar.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/stdlevvar.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/stdlevvar.F90	(revision 984)
@@ -0,0 +1,278 @@
+!
+! $Header$
+!
+      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, rugos, psol, pat1, &
+                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar)
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!
+!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
+!
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_10m--output-R- vitesse du vent a 10m
+!AM
+! t_10m--output-R- temperature de l'air a 10m
+! q_10m--output-R- humidite specifique a 10m
+! ustar--output-R- u*
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
+      REAL, dimension(klon), intent(in) :: qsurf, rugos
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
+      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
+!-------------------------------------------------------------------------
+      include "YOMCST.h"
+!IM PLUS
+      include "YOETHF.h"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+!     INTEGER, parameter :: niter=6, ncon=niter-1
+      INTEGER, parameter :: niter=2, ncon=niter-1
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: zri1, cdran
+      REAL, dimension(klon) :: cdram, cdrah
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      REAL, dimension(klon) :: testar, qstar
+      REAL, dimension(klon) :: zdte, zdq   
+! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
+      DOUBLE PRECISION, dimension(klon) :: lmon
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: temp, pref
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+!convertgence
+      REAL, dimension(klon) :: te_zref_con, q_zref_con
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr
+!     REAL, dimension(klon) :: conv_te, conv_q
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+       speed(i)=SQRT(u1(i)**2+v1(i)**2)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+      CALL coefcdrag(klon, knon, nsrf, zxli, &
+ &                   speed, t1, q1, z1, psol, &
+ &                   ts1, qsurf, rugos, okri, ri1,  &         
+ &                   cdram, cdrah, cdran, zri1, pref)            
+!
+!---------Star variables----------------------------------------------------
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
+        zdte(i) = tpot(i) - ts1(i)
+        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
+!
+!
+!IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
+        zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
+!
+        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
+        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
+        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
+ &                (RKAR * RG * testar(i))
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+        q_zref_p(i) = q_zref(i)
+!       te_zref_p(i) = te_zref(i)
+        temp_p(i) = temp(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &           
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq) 
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i) 
+!
+! return to normal temperature
+!
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+!
+!IM +++
+!         IF(temp(i).GT.350.) THEN
+!           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
+!         ENDIF
+!IM ---
+!
+        IF(n.EQ.ncon) THEN
+          te_zref_con(i) = te_zref(i)
+          q_zref_con(i) = q_zref(i)
+        ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
+!
+!       DO i = 1, knon
+!         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
+!         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
+!IM +++
+!         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
+!           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
+!           q_zref_con(i),q_zref(i),conv_q(i)
+!         ENDIF
+!IM ---
+!       ENDDO
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+!       IF(zri1(i).LT.0.) THEN
+!         IF(nsrf.EQ.1) THEN
+!           ok_pred(i)=1.
+!           ok_corr(i)=0.
+!         ELSE
+!           ok_pred(i)=0.
+!           ok_corr(i)=1.
+!         ENDIF
+!       ELSE
+!         ok_pred(i)=0.
+!         ok_corr(i)=1.
+!       ENDIF
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!IM +++
+!       IF(n.EQ.niter) THEN
+!       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
+!         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
+!         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ENDIF
+!       ENDIF
+!IM ---
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+        u_zref_p(i) = u_zref(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq)
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i)
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                   (1 + RVTMP2 * max(q_zref(i),0.0))
+        ENDDO 
+!
+      ENDDO
+!
+      DO i = 1, knon
+        u_zref_c(i) = u_zref(i)
+!
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+!
+!AM
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!MA
+      ENDDO
+! 
+      RETURN
+      END subroutine stdlevvar
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/suphec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/suphec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/suphec.F	(revision 984)
@@ -0,0 +1,211 @@
+!
+! $Header$
+!
+      SUBROUTINE suphec
+C
+#include "YOMCST.h"
+#include "YOETHF.h"
+cIM cf. JLD
+       LOGICAL firstcall
+       SAVE firstcall
+c$OMP THREADPRIVATE(firstcall)
+       DATA firstcall /.TRUE./
+       
+       IF (firstcall) THEN
+         PRINT*, 'suphec initialise les constantes du GCM'
+         firstcall = .FALSE.
+       ELSE
+         PRINT*, 'suphec DEJA APPELE '
+         RETURN
+       ENDIF
+C      -----------------------------------------------------------------
+C
+C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
+C              -----------------------------
+C
+      WRITE(UNIT=6,FMT='(''0*** Constants of the ICM   ***'')')
+      RPI=2.*ASIN(1.)
+      RCLUM=299792458.
+      RHPLA=6.6260755E-34
+      RKBOL=1.380658E-23
+      RNAVO=6.0221367E+23
+      WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')')
+      WRITE(UNIT=6,FMT='(''           PI = '',E13.7,'' -'')')RPI
+      WRITE(UNIT=6,FMT='(''            c = '',E13.7,''m s-1'')')
+     S RCLUM
+      WRITE(UNIT=6,FMT='(''            h = '',E13.7,''J s'')')
+     S RHPLA
+      WRITE(UNIT=6,FMT='(''            K = '',E13.7,''J K-1'')')
+     S RKBOL
+      WRITE(UNIT=6,FMT='(''            N = '',E13.7,''mol-1'')')
+     S RNAVO
+C
+C     ----------------------------------------------------------------
+C
+C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
+C              ------------------------------
+C
+      RDAY=86400.
+      REA=149597870000.
+      REPSM=0.409093
+C
+      RSIYEA=365.25*RDAY*2.*RPI/6.283076
+      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
+      ROMEGA=2.*RPI/RSIDAY
+c
+c exp1      R_ecc = 0.05
+c exp1      R_peri = 102.04
+c exp1      R_incl = 22.5
+c exp1      print*, 'Parametres orbitaux modifies'
+c ref      R_ecc = 0.016724
+c ref      R_peri = 102.04
+c ref      R_incl = 23.5
+c
+cIM 161002 : pour avoir les ctes AMIP II
+cIM 161002   R_ecc = 0.016724
+cIM 161002   R_peri = 102.04
+cIM 161002   R_incl = 23.5
+cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
+c     R_ecc = 0.016715
+c     R_peri = 102.7
+c     R_incl = 23.441
+c
+      WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')')
+      WRITE(UNIT=6,FMT='(''          day = '',E13.7,'' s'')')RDAY
+      WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA
+      WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
+      WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA
+      WRITE(UNIT=6,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
+      WRITE(UNIT=6,FMT='(''        omega = '',E13.7,'' s-1'')')
+     S                  ROMEGA
+c     write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+c     write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+c     write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+C
+C     ------------------------------------------------------------------
+C
+C*       3.    DEFINE GEOIDE.
+C              --------------
+C
+      RG=9.80665
+      RA=6371229.
+      R1SA=SNGL(1.D0/DBLE(RA))
+      WRITE(UNIT=6,FMT='('' ***         Geoide         ***'')')
+      WRITE(UNIT=6,FMT='(''      Gravity = '',E13.7,'' m s-2'')')
+     S      RG
+      WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA
+      WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA
+C
+C     -----------------------------------------------------------------
+C
+C*       4.    DEFINE RADIATION CONSTANTS.
+C              ---------------------------
+C
+c z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+      rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15.
+cIM init. dans conf_phys.F90   RI0=1365.
+      WRITE(UNIT=6,FMT='('' ***        Radiation       ***'')')
+      WRITE(UNIT=6,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''
+     S )')  RSIGMA
+cIM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
+cIM init. dans conf_phys.F90  S      RI0
+C
+C     -----------------------------------------------------------------
+C
+C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+C              ------------------------------------------
+C
+      R=RNAVO*RKBOL
+      RMD=28.9644
+      RMO3=47.9942
+      RMV=18.0153
+      RD=1000.*R/RMD
+      RV=1000.*R/RMV
+      RCPD=3.5*RD
+      RCVD=RCPD-RD
+      RCPV=4. *RV
+      RCVV=RCPV-RV
+      RKAPPA=RD/RCPD
+      RETV=RV/RD-1.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas     ***'')')
+      WRITE(UNIT=6,FMT='('' Perfect gas  = '',e13.7)') R
+      WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD
+      WRITE(UNIT=6,FMT='('' Ozone   mass = '',e13.7)') RMO3
+      WRITE(UNIT=6,FMT='('' Vapour  mass = '',e13.7)') RMV
+      WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD
+      WRITE(UNIT=6,FMT='('' Vapour  cst. = '',e13.7)') RV
+      WRITE(UNIT=6,FMT='(''         Cpd  = '',e13.7)') RCPD
+      WRITE(UNIT=6,FMT='(''         Cvd  = '',e13.7)') RCVD
+      WRITE(UNIT=6,FMT='(''         Cpv  = '',e13.7)') RCPV
+      WRITE(UNIT=6,FMT='(''         Cvv  = '',e13.7)') RCVV
+      WRITE(UNIT=6,FMT='(''      Rd/Cpd  = '',e13.7)') RKAPPA
+      WRITE(UNIT=6,FMT='(''     Rv/Rd-1  = '',e13.7)') RETV
+C
+C     ----------------------------------------------------------------
+C
+C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+C              ---------------------------------------------
+C
+      RCW=RCPV
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid  ***'')')
+      WRITE(UNIT=6,FMT='(''         Cw   = '',E13.7)') RCW
+C
+C     ----------------------------------------------------------------
+C
+C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+C              --------------------------------------------
+C
+      RCS=RCPV
+      WRITE(UNIT=6,FMT='('' *** thermodynamic, solid   ***'')')
+      WRITE(UNIT=6,FMT='(''         Cs   = '',E13.7)') RCS
+C
+C     ----------------------------------------------------------------
+C
+C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+C              ----------------------------------------------------
+C
+      RTT=273.16
+      RLVTT=2.5008E+6
+      RLSTT=2.8345E+6
+      RLMLT=RLSTT-RLVTT
+      RATM=100000.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans.  ***'')')
+      WRITE(UNIT=6,FMT='('' Fusion point  = '',E13.7)') RTT
+      WRITE(UNIT=6,FMT='(''        RLvTt  = '',E13.7)') RLVTT
+      WRITE(UNIT=6,FMT='(''        RLsTt  = '',E13.7)') RLSTT
+      WRITE(UNIT=6,FMT='(''        RLMlt  = '',E13.7)') RLMLT
+      WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM
+      WRITE(UNIT=6,FMT='('' Latent heat :  '')')
+C
+C     ----------------------------------------------------------------
+C
+C*       9.    SATURATED VAPOUR PRESSURE.
+C              --------------------------
+C
+      RESTT=611.14
+      RGAMW=(RCW-RCPV)/RV
+      RBETW=RLVTT/RV+RGAMW*RTT
+      RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
+      RGAMS=(RCS-RCPV)/RV
+      RBETS=RLSTT/RV+RGAMS*RTT
+      RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
+      RGAMD=RGAMS-RGAMW
+      RBETD=RBETS-RBETW
+      RALPD=RALPS-RALPW
+C
+C     ------------------------------------------------------------------
+c
+c calculer les constantes pour les fonctions thermodynamiques
+c
+      RVTMP2=RCPV/RCPD-1.
+      RHOH2O=RATM/100.
+      R2ES=RESTT*RD/RV
+      R3LES=17.269
+      R3IES=21.875
+      R4LES=35.86
+      R4IES=7.66
+      R5LES=R3LES*(RTT-R4LES)
+      R5IES=R3IES*(RTT-R4IES)
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_bucket_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_bucket_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_bucket_mod.F90	(revision 984)
@@ -0,0 +1,317 @@
+!
+! $Header$
+!
+MODULE surf_land_bucket_mod
+!
+! Surface land bucket module
+!
+! This module is used when no external land model is choosen.
+!
+  USE fonte_neige_mod
+  USE calcul_fluxs_mod
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+ 
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+       spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, ps, &
+       u1_lay, v1_lay, rugoro, &
+       radsol, snow, qsol, agesno, tsoil, &
+       qsurf, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l)
+
+!****************************************************************************************
+! Bucket calculations for surface. 
+!
+    INCLUDE "clesphys.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    LOGICAL, INTENT(IN)                     :: debut
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: ps
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: soilcap, soilflux
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon) :: alb_neig
+    REAL, DIMENSION(klon) :: zfra
+    INTEGER               :: i
+!
+!****************************************************************************************
+
+
+!
+!* Read from limit.nc : albedo(alb_new), length of rugosity(z0_new)
+!
+    CALL interfsur_lim(itime, dtime, jour, &
+         knon, knindex, debut,  &
+         alb_new, z0_new)
+    
+!
+!* Calcultaion of fluxes 
+!
+! calculate constants
+    CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
+       
+! calculate temperature, heat capacity and conduction flux in soil
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       DO i=1, knon
+          cal(i) = RCPD / soilcap(i)
+          radsol(i) = radsol(i)  + soilflux(i)
+       END DO
+    ELSE 
+       cal(:) = RCPD * capsol(:)
+    ENDIF
+    
+    CALL calcul_fluxs(knon, is_ter, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+!
+!* Calculate snow height, run_off, age of snow
+!      
+    CALL fonte_neige( knon, is_ter, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+!
+!* Calculate the age of snow
+!
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    
+    DO i=1, knon
+       zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0)))
+       alb_new(i)  = alb_neig(i) *zfra(i) + alb_new(i)*(1.0-zfra(i))
+    END DO
+
+    alblw(:) = 0.0
+    alblw(1:knon) = alb_new(1:knon)
+
+!
+!* Calculate the rugosity
+!
+    z0_new = SQRT(z0_new**2+rugoro**2)
+       
+!
+!* End
+!
+  END SUBROUTINE surf_land_bucket
+!
+!****************************************************************************************
+!
+  SUBROUTINE interfsur_lim(itime, dtime, jour, &
+       knon, knindex, debut, &
+       lmt_alb_p, lmt_rug_p)
+    
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_alb_p      Albedo lu 
+!   lmt_rug_p      longueur de rugosite lue
+
+    INCLUDE "netcdf.inc"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime
+    REAL   , INTENT(IN)                      :: dtime
+    INTEGER, INTENT(IN)                      :: jour
+    INTEGER, INTENT(IN)                      :: knon
+    INTEGER, DIMENSION(klon_loc), INTENT(IN) :: knindex
+    LOGICAL, INTENT(IN)                      :: debut
+
+! Output variables
+!****************************************************************************************
+    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_alb_p
+    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_rug_p
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER,SAVE   :: lmt_pas     ! frequence de lecture des conditions limites 
+                                  ! (en pas de physique)
+    !$OMP THREADPRIVATE(lmt_pas) 
+    LOGICAL,SAVE   :: deja_lu_sur ! pour indiquer que le jour a lire a deja
+                                  ! lu pour une surface precedente
+    !$OMP THREADPRIVATE(deja_lu_sur) 
+    INTEGER,SAVE                           :: jour_lu_sur 
+    !$OMP THREADPRIVATE(jour_lu_sur) 
+    CHARACTER (len = 20),SAVE              :: fich ='limit.nc'
+    !$OMP THREADPRIVATE(fich) 
+    LOGICAL,SAVE                           :: check = .FALSE.
+    !$OMP THREADPRIVATE(check) 
+! Champs lus dans le fichier de CL
+    REAL, ALLOCATABLE , SAVE, DIMENSION(:) :: alb_lu_p, rug_lu_p
+    !$OMP THREADPRIVATE(alb_lu_p, rug_lu_p) 
+
+! quelques variables pour netcdf
+    INTEGER ,SAVE                          :: nid, nvarid
+    !$OMP THREADPRIVATE(nid, nvarid) 
+    INTEGER, DIMENSION(2),SAVE             :: start, epais
+    !$OMP THREADPRIVATE(start, epais) 
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                :: ii, ierr
+    CHARACTER (len = 20)                   :: modname = 'interfsur_lim'
+    CHARACTER (len = 80)                   :: abort_message
+    REAL, DIMENSION(klon_glo)              :: alb_lu
+    REAL, DIMENSION(klon_glo)              :: rug_lu
+
+!
+! End delaration
+!****************************************************************************************
+
+    IF (debut) THEN
+       lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+       jour_lu_sur = jour - 1
+       ALLOCATE(alb_lu_p(klon_loc))
+       ALLOCATE(rug_lu_p(klon_loc))
+    ENDIF
+    
+    IF ((jour - jour_lu_sur) /= 0) deja_lu_sur = .FALSE.
+  
+    IF (check) WRITE(*,*) modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur 
+    IF (check) WRITE(*,*) modname,':: itime, lmt_pas', itime, lmt_pas
+    IF (check) CALL flush(6)
+
+!    
+! Tester d'abord si c'est le moment de lire le fichier
+!
+    IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu_sur) THEN
+
+!
+! Ouverture et lecture du fichier
+!
+!$OMP MASTER
+       IF (is_mpi_root) THEN
+          fich = TRIM(fich)
+          IF (check) WRITE(*,*)modname,' ouverture fichier ',fich
+          IF (check) CALL flush(6)
+          ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+          IF (ierr.NE.NF_NOERR) THEN
+             abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+! 
+! La tranche de donnees a lire:
+          start(1) = 1
+          start(2) = jour
+          epais(1) = klon_glo
+          epais(2) = 1
+!
+! Lecture albedo
+          ierr = NF_INQ_VARID(nid, 'ALB', nvarid)
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Le champ <ALB> est absent'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, alb_lu)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu)
+#endif
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Lecture echouee pour <ALB>'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+!
+! Lecture rugosite!
+          ierr = NF_INQ_VARID(nid, 'RUG', nvarid)
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Le champ <RUG> est absent'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, rug_lu)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu)
+#endif
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Lecture echouee pour <RUG>'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+
+!
+! Fin de lecture
+          ierr = NF_CLOSE(nid)
+
+       ENDIF ! is_mpi_root
+!$OMP END MASTER
+
+       CALL Scatter(alb_lu,alb_lu_p)
+       CALL Scatter(rug_lu,rug_lu_p)
+
+       deja_lu_sur = .TRUE.
+       jour_lu_sur = jour       
+
+    ENDIF
+  
+!
+! Recopie des variables dans les champs de sortie
+!
+    lmt_alb_p(:) = 999999.
+    lmt_rug_p(:) = 999999.
+    DO ii = 1, knon
+       lmt_alb_p(ii) = alb_lu_p(knindex(ii))
+       lmt_rug_p(ii) = rug_lu_p(knindex(ii))
+    ENDDO
+    
+
+  END SUBROUTINE interfsur_lim
+!
+!****************************************************************************************
+!
+END MODULE surf_land_bucket_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_mod.F90	(revision 984)
@@ -0,0 +1,142 @@
+!
+! $Header$
+!
+MODULE surf_land_mod
+  
+  USE surface_data, ONLY    : ok_veget
+  USE dimphy
+ 
+#ifdef CPP_VEGET
+  USE surf_land_orchidee_mod
+#endif
+  USE surf_land_bucket_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
+       rlon, rlat, &
+       debut, lafin, zlev, epot_air, ccanopy, sollwdown, swnet, swdown, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_ter)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: date0
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    LOGICAL, INTENT(IN)                     :: debut, lafin
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: zlev, epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)       :: sollwdown, swnet, swdown    
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: ps
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_ter
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: ps_tmp, p1lay_tmp
+    REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used
+    INTEGER               :: i
+
+
+!**************************************************************************************** 
+! Choice between call to vegetation model (ok_veget=true) or simple calculation below
+!
+!****************************************************************************************
+   IF (ok_veget) THEN
+!****************************************************************************************
+!  Call model sechiba
+!
+!****************************************************************************************
+       p1lay_tmp(:)      = 0.0
+       ps_tmp(:)         = 0.0
+       p1lay_tmp(1:knon) = p1lay(1:knon)/100.
+       ps_tmp(1:knon)    = ps(1:knon)/100.
+
+#ifdef CPP_VEGET
+       CALL surf_land_orchidee(itime, dtime, date0, knon, &
+            knindex, rlon, rlat, pctsrf, &
+            debut, lafin, &
+            zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+            tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            precip_rain, precip_snow, sollwdown, swnet, swdown, &
+            ps_tmp, &
+            evap, fluxsens, fluxlat, &              
+            tsol_rad, tsurf_new, alb_new, alblw, &
+            emis_new, z0_new, qsurf)       
+#endif
+
+!  
+!* Ajout de la contribution du relief
+!  
+       DO i=1,knon
+          z0_new(i) = SQRT(z0_new(i)**2 + rugoro(i)**2)
+       ENDDO
+
+    ELSE  ! not ok_veget
+!****************************************************************************************
+! No extern vegetation model choosen, call simple bucket calculations instead.
+!
+!****************************************************************************************
+       CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+            tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+            spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, ps, &
+            u1_lay, v1_lay, rugoro, &
+            radsol, snow, qsol, agesno, tsoil, &
+            qsurf, z0_new, alblw, evap, fluxsens, fluxlat, &
+            tsurf_new, alb_new, dflux_s, dflux_l)
+
+    ENDIF ! ok_veget
+
+!****************************************************************************************
+! Return the pourcentage of land in each grid cell, even if not changed in here!
+!
+!****************************************************************************************
+    pctsrf_ter(:) = pctsrf(:,is_ter)
+
+
+  END SUBROUTINE surf_land
+!
+!****************************************************************************************
+!  
+END MODULE surf_land_mod
+!
+!****************************************************************************************
+!  
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_orchidee_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_orchidee_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_land_orchidee_mod.F90	(revision 984)
@@ -0,0 +1,701 @@
+!
+! $Header$
+!
+MODULE surf_land_orchidee_mod
+!
+! This module controles the interface towards the model ORCHIDEE
+!
+! Subroutines in this module : surf_land_orchidee
+!                              Init_orchidee_index
+!                              Get_orchidee_communicator
+!                              Init_neighbours
+#ifdef CPP_VEGET
+
+  USE dimphy
+  USE intersurf     ! module d'ORCHIDEE
+  USE cpl_mod,      ONLY : cpl_send_land_fields
+  USE surface_data, ONLY : ocean, ok_veget
+  USE comgeomphy,   ONLY : cuphy, cvphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC  :: surf_land_orchidee
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
+       knindex, rlon, rlat, pctsrf, &
+       debut, lafin, &
+       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       precip_rain, precip_snow, lwdown, swnet, swdown, &
+       ps, &
+       evap, fluxsens, fluxlat, &              
+       tsol_rad, tsurf_new, alb_new, alblw, &
+       emis_new, z0_new, qsurf)
+!    
+! Cette routine sert d'interface entre le modele atmospherique et le 
+! modele de sol continental. Appel a sechiba
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes de la grille entiere
+!   rlat         latitudes de la grille entiere
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   debut        logical: 1er appel a la physique (lire les restart)
+!   lafin        logical: dernier appel a la physique (ecrire les restart)
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   plev         hauteur de la premiere couche (Pa)      
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp pot de l'air
+!   ccanopy      concentration CO2 canopee
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   lwdown       flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb_new      albedo
+!   emis_new     emissivite
+!   z0_new       surface roughness
+!   qsurf        air moisture at surface
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "dimensions.h"
+  
+!
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    REAL, INTENT(IN)                          :: dtime
+    REAL, INTENT(IN)                          :: date0
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    LOGICAL, INTENT(IN)                       :: debut, lafin
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
+    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)         :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)         :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)         :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)         :: lwdown, swnet, swdown, ps
+    REAL, DIMENSION(klon)                     :: swdown_vrai
+
+! Parametres de sortie
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: evap, fluxsens, fluxlat, qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tsol_rad, tsurf_new, alb_new, alblw
+    REAL, DIMENSION(klon), INTENT(OUT)        :: emis_new, z0_new
+
+! Local
+!****************************************************************************************
+    INTEGER                                   :: ij, jj, igrid, ireal, index
+    INTEGER                                   :: error
+    CHARACTER (len = 20)                      :: modname = 'surf_land_orchidee'
+    CHARACTER (len = 80)                      :: abort_message
+    LOGICAL,SAVE                              :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! type de couplage dans sechiba
+!  character (len=10)   :: coupling = 'implicit' 
+! drapeaux controlant les appels dans SECHIBA
+!  type(control_type), save   :: control_in
+! Preserved albedo
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: albedo_keep, zlev
+    !$OMP THREADPRIVATE(albedo_keep,zlev)
+! coordonnees geographiques
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
+    !$OMP THREADPRIVATE(lalo)
+! pts voisins
+    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
+    !$OMP THREADPRIVATE(neighbours)
+! fractions continents
+    REAL,ALLOCATABLE, DIMENSION(:), SAVE      :: contfrac
+    !$OMP THREADPRIVATE(contfrac)
+! resolution de la grille
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: resolution
+    !$OMP THREADPRIVATE(resolution)
+
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: lon_scat, lat_scat  
+    !$OMP THREADPRIVATE(lon_scat,lat_scat)
+
+    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
+    !$OMP THREADPRIVATE(lrestart_read)
+    LOGICAL, SAVE                             :: lrestart_write = .FALSE.
+    !$OMP THREADPRIVATE(lrestart_write)
+
+    REAL, DIMENSION(knon,2)                   :: albedo_out
+    !$OMP THREADPRIVATE(albedo_out)
+
+! Pb de nomenclature
+    REAL, DIMENSION(klon)                     :: petA_orc, peqA_orc
+    REAL, DIMENSION(klon)                     :: petB_orc, peqB_orc
+! Pb de correspondances de grilles
+    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  :: ig, jg
+    !$OMP THREADPRIVATE(ig,jg)
+    INTEGER :: indi, indj
+    INTEGER, SAVE, ALLOCATABLE,DIMENSION(:)   :: ktindex
+    !$OMP THREADPRIVATE(ktindex)
+
+! Essai cdrag
+    REAL, DIMENSION(klon)                     :: cdrag
+    INTEGER,SAVE                              :: offset
+    !$OMP THREADPRIVATE(offset)
+
+    REAL, DIMENSION(klon_glo)                 :: rlon_g,rlat_g
+    INTEGER, SAVE                             :: orch_comm
+    !$OMP THREADPRIVATE(orch_comm)
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: coastalflow
+    !$OMP THREADPRIVATE(coastalflow)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: riverflow
+    !$OMP THREADPRIVATE(riverflow)
+!
+! Fin definition
+!****************************************************************************************
+
+    IF (check) WRITE(lunout,*)'Entree ', modname
+    IF (check) WRITE(lunout,*)'ok_veget = ',ok_veget
+  
+! Initialisation
+  
+    IF (debut) THEN
+       ALLOCATE(ktindex(knon))
+       IF ( .NOT. ALLOCATED(albedo_keep)) THEN
+          ALLOCATE(albedo_keep(klon))
+          ALLOCATE(zlev(knon))
+       ENDIF
+! Pb de correspondances de grilles
+       ALLOCATE(ig(klon))
+       ALLOCATE(jg(klon))
+       ig(1) = 1
+       jg(1) = 1
+       indi = 0
+       indj = 2
+       DO igrid = 2, klon - 1
+          indi = indi + 1
+          IF ( indi > iim) THEN
+             indi = 1
+             indj = indj + 1
+          ENDIF
+          ig(igrid) = indi
+          jg(igrid) = indj
+       ENDDO
+       ig(klon) = 1
+       jg(klon) = jjm + 1
+
+       IF ((.NOT. ALLOCATED(lalo))) THEN
+          ALLOCATE(lalo(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lalo'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lon_scat))) THEN
+          ALLOCATE(lon_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lon_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lat_scat))) THEN
+          ALLOCATE(lat_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lat_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       lon_scat = 0.
+       lat_scat = 0.
+       DO igrid = 1, knon
+          index = knindex(igrid)
+          lalo(igrid,2) = rlon(index)
+          lalo(igrid,1) = rlat(index)
+       ENDDO
+
+       
+       
+       CALL Gather(rlon,rlon_g)
+       CALL Gather(rlat,rlat_g)
+
+       IF (is_mpi_root) THEN
+          index = 1
+          DO jj = 2, jjm
+             DO ij = 1, iim
+                index = index + 1
+                lon_scat(ij,jj) = rlon_g(index)
+                lat_scat(ij,jj) = rlat_g(index)
+             ENDDO
+          ENDDO
+          lon_scat(:,1) = lon_scat(:,2)
+          lat_scat(:,1) = rlat_g(1)
+          lon_scat(:,jjm+1) = lon_scat(:,2)
+          lat_scat(:,jjm+1) = rlat_g(klon_glo)
+       ENDIF
+   
+
+!
+! Allouer et initialiser le tableau des voisins et des fraction de continents
+!
+       IF ( (.NOT.ALLOCATED(neighbours))) THEN
+          ALLOCATE(neighbours(knon,8), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation neighbours'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       neighbours = -1.
+       IF (( .NOT. ALLOCATED(contfrac))) THEN
+          ALLOCATE(contfrac(knon), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation contfrac'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       DO igrid = 1, knon
+          ireal = knindex(igrid)
+          contfrac(igrid) = pctsrf(ireal,is_ter)
+       ENDDO
+
+
+       CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
+
+!
+!  Allocation et calcul resolutions
+       IF ( (.NOT.ALLOCATED(resolution))) THEN
+          ALLOCATE(resolution(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation resolution'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       DO igrid = 1, knon
+          ij = knindex(igrid)
+          resolution(igrid,1) = cuphy(ij)
+          resolution(igrid,2) = cvphy(ij)
+       ENDDO
+     
+       ALLOCATE(coastalflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation coastalflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+       ALLOCATE(riverflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation riverflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+
+    ENDIF                          ! (fin debut) 
+
+! 
+! Appel a la routine sols continentaux
+!
+    IF (lafin) lrestart_write = .TRUE.
+    IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
+    
+    petA_orc(1:knon) = petBcoef(1:knon) * dtime
+    petB_orc(1:knon) = petAcoef(1:knon)
+    peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
+    peqB_orc(1:knon) = peqAcoef(1:knon)
+
+    cdrag = 0.
+    cdrag(1:knon) = tq_cdrag(1:knon)
+
+! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
+    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
+
+
+! PF et PASB
+!   where(cdrag > 0.01) 
+!     cdrag = 0.01
+!   endwhere
+!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
+
+!
+! Init Orchidee
+!
+!  if (pole_nord) then 
+!    offset=0
+!    ktindex(:)=ktindex(:)+iim-1
+!  else
+!    offset = klon_mpi_begin-1+iim-1
+!    ktindex(:)=ktindex(:)+MOD(offset,iim)
+!    offset=offset-MOD(offset,iim)
+!  endif
+  
+    IF (debut) THEN
+       CALL Get_orchidee_communicator(knon,orch_comm)
+       IF (knon /=0) THEN
+          CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+
+#ifndef CPP_PARA
+#define ORC_PREPAR
+#endif
+#ifdef ORC_PREPAR
+          ! Interface for ORCHIDEE version 1.9 or earlier compiled in sequential mode(without preprocessing flag CPP_PARA)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
+               lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+               cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+               precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
+               evap, fluxsens, fluxlat, coastalflow, riverflow, &
+               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+               lon_scat, lat_scat)
+
+#else          
+          ! Interface for ORCHIDEE version 1.9 compiled in parallel mode(with preprocessing flag CPP_PARA)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, & 
+               orch_comm, dtime, lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+               cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+               precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), &
+               evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+               tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+               lon_scat, lat_scat)
+#endif
+          
+       ENDIF
+
+       albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+    ENDIF
+
+!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
+    swdown_vrai(1:knon) = swdown(1:knon)
+
+    IF (knon /=0) THEN
+    
+#ifdef ORC_PREPAR
+       ! Interface for ORCHIDEE version 1.9 or earlier compiled in sequential mode(without preprocessing flag CPP_PARA)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, &
+            lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+            cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+            precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
+            evap, fluxsens, fluxlat, coastalflow, riverflow, &
+            tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+            lon_scat, lat_scat)
+       
+#else
+       ! Interface for ORCHIDEE version 1.9 compiled in parallel mode(with preprocessing flag CPP_PARA)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & 
+            orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+            cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+            precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
+            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+            lon_scat, lat_scat)
+#endif
+       
+    ENDIF
+
+    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+!* Send to coupler
+!
+    IF (ocean=='couple') THEN
+       CALL cpl_send_land_fields(itime, knon, knindex, &
+            riverflow, coastalflow)
+    ENDIF
+
+    alb_new(1:knon) = albedo_out(1:knon,1) 
+    alblw(1:knon) = albedo_out(1:knon,2)
+
+! Convention orchidee: positif vers le haut
+    fluxsens(1:knon) = -1. * fluxsens(1:knon)
+    fluxlat(1:knon)  = -1. * fluxlat(1:knon)
+    
+!  evap     = -1. * evap
+
+    IF (debut) lrestart_read = .FALSE.
+    
+  END SUBROUTINE surf_land_orchidee
+!
+!****************************************************************************************
+!
+  SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+    
+    INCLUDE "dimensions.h"
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                   :: knon
+    INTEGER, INTENT(IN)                   :: orch_comm
+    INTEGER, DIMENSION(klon), INTENT(IN)  :: knindex
+
+! Output arguments
+!****************************************************************************************
+    INTEGER, INTENT(OUT)                  :: offset
+    INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex
+
+! Local varables
+!****************************************************************************************
+#ifdef CPP_PARA
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: status
+#endif
+
+    INTEGER                               :: MyLastPoint
+    INTEGER                               :: LastPoint
+    INTEGER                               :: mpi_rank_orch
+    INTEGER                               :: mpi_size_orch
+    INTEGER                               :: ierr 
+!
+! End definition
+!****************************************************************************************
+
+    MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1
+    
+    IF (is_parallel) THEN
+#ifdef CPP_PARA    
+       CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr)
+       CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr)
+#endif
+    ELSE
+       mpi_rank_orch=0
+       mpi_size_orch=1
+    ENDIF
+
+    IF (is_parallel) THEN
+       IF (mpi_rank_orch /= 0) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr)
+#endif
+       ENDIF
+       
+       IF (mpi_rank_orch /= mpi_size_orch-1) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr)  
+#endif
+       ENDIF
+    ENDIF
+    
+    IF (mpi_rank_orch == 0) THEN 
+       offset=0
+    ELSE
+       offset=LastPoint-MOD(LastPoint,iim)
+    ENDIF
+    
+    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1	
+    
+
+  END SUBROUTINE  Init_orchidee_index
+!
+!****************************************************************************************
+! 
+  SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+
+    INTEGER,INTENT(IN)  :: knon
+    INTEGER,INTENT(OUT) :: orch_comm
+    
+    INTEGER             :: color
+    INTEGER             :: ierr
+!
+! End definition
+!****************************************************************************************
+
+    IF (knon==0) THEN 
+       color = 0
+    ELSE 
+       color = 1
+    ENDIF
+    
+#ifdef CPP_PARA    
+    CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
+#endif
+    
+  END SUBROUTINE Get_orchidee_communicator
+!
+!****************************************************************************************
+!  
+  SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf)
+    
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: ktindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: pctsrf
+    
+! Output arguments
+!****************************************************************************************
+    INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: knon_g
+    INTEGER                              :: i, igrid, jj, ij, iglob
+    INTEGER                              :: ierr, ireal, index
+    INTEGER, DIMENSION(0:mpi_size-1)     :: knon_nb
+    INTEGER, DIMENSION(0:mpi_size-1)     :: displs
+    INTEGER, DIMENSION(8,3)              :: off_ini
+    INTEGER, DIMENSION(8)                :: offset  
+    INTEGER, DIMENSION(knon)             :: ktindex_p
+    INTEGER, DIMENSION(iim,jjm+1)        :: correspond
+    INTEGER, ALLOCATABLE, DIMENSION(:)   :: ktindex_g
+    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
+    REAL, DIMENSION(klon_glo)            :: pctsrf_g
+    
+!
+! End definition
+!****************************************************************************************
+
+    IF (is_sequential) THEN
+       knon_nb(:)=knon
+    ELSE  
+       
+#ifdef CPP_PARA  
+       CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+       knon_g=SUM(knon_nb(:))
+       ALLOCATE(ktindex_g(knon_g))
+       ALLOCATE(neighbours_g(knon_g,8))
+       neighbours_g(:,:)=-1
+       displs(0)=0
+       DO i=1,mpi_size-1
+          displs(i)=displs(i-1)+knon_nb(i-1)
+       ENDDO
+    ENDIF
+    
+    ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1
+    
+    IF (is_sequential) THEN
+       ktindex_g(:)=ktindex_p(:)
+    ELSE
+       
+#ifdef CPP_PARA  
+       CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,&
+            displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    CALL Gather(pctsrf,pctsrf_g)
+    
+    IF (is_mpi_root) THEN
+!  Initialisation des offset    
+!
+! offset bord ouest
+       off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
+       off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
+       off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
+! offset point normal
+       off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
+       off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
+       off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
+! offset bord   est
+       off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
+       off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
+       off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
+!
+!
+! Attention aux poles
+!
+       DO igrid = 1, knon_g
+          index = ktindex_g(igrid)
+          jj = INT((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+          correspond(ij,jj) = igrid
+       ENDDO
+       
+       DO igrid = 1, knon_g
+          iglob = ktindex_g(igrid)
+          IF (MOD(iglob, iim) == 1) THEN
+             offset = off_ini(:,1)
+          ELSE IF(MOD(iglob, iim) == 0) THEN
+             offset = off_ini(:,3)
+          ELSE
+             offset = off_ini(:,2)
+          ENDIF
+          DO i = 1, 8
+             index = iglob + offset(i)
+             ireal = (MIN(MAX(1, index - iim + 1), klon_glo))
+             IF (pctsrf_g(ireal) > EPSFRA) THEN
+                jj = INT((index - 1)/iim) + 1
+                ij = index - (jj - 1) * iim
+                neighbours_g(igrid, i) = correspond(ij, jj)
+             ENDIF
+          ENDDO
+       ENDDO
+
+    ENDIF
+    
+    DO i=1,8
+       IF (is_sequential) THEN
+          neighbours(:,i)=neighbours_g(:,i)
+       ELSE
+#ifdef CPP_PARA
+          CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) 
+#endif
+       ENDIF
+    ENDDO
+    
+  END SUBROUTINE Init_neighbours
+!
+!****************************************************************************************
+!
+
+#endif
+
+END MODULE surf_land_orchidee_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_landice_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_landice_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_landice_mod.F90	(revision 984)
@@ -0,0 +1,170 @@
+!
+! $Header$
+!
+MODULE surf_landice_mod
+  
+  USE dimphy
+  USE surface_data,     ONLY : ocean, calice, calsno
+  USE fonte_neige_mod,  ONLY : fonte_neige, run_off_lic
+  USE cpl_mod,          ONLY : cpl_send_landice_fields
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_landice(itime, dtime, knon, knindex, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_lic)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input variables 
+!****************************************************************************************
+    INTEGER, INTENT(IN)                           :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(in)          :: knindex
+    REAL, INTENT(in)                              :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)             :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)             :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)             :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)             :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)             :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)             :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)             :: ps
+    REAL, DIMENSION(klon), INTENT(IN)             :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_lic
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)    :: soilcap, soilflux
+    REAL, DIMENSION(klon)    :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)    :: zfra, alb_neig
+
+! End definition
+!****************************************************************************************
+!
+! Initialize output variables
+    alblw(:) =  999999.
+    alb_new(:) = 999999.
+
+
+!****************************************************************************************
+! Soil calculations
+! 
+!****************************************************************************************
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_lic, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon)  = radsol(1:knon) + soilflux(1:knon)
+    ELSE 
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno
+    ENDIF
+
+
+!****************************************************************************************
+! Calulate fluxes
+!
+!****************************************************************************************
+    beta(:) = 1.0
+    dif_grnd(:) = 0.0
+
+    CALL calcul_fluxs(knon, is_lic, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+
+!****************************************************************************************
+! Calculate snow height, age, run-off,..
+!    
+!****************************************************************************************
+    CALL fonte_neige( knon, is_lic, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb_new(1:knon)  = alb_neig(1:knon)*zfra(1:knon) + &
+         0.6 * (1.0-zfra(1:knon))
+!
+!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux"
+!       alb_new(1 : knon)  = 0.6 !IM cf FH/GK 
+!       alb_new(1 : knon)  = 0.82
+!       alb_new(1 : knon)  = 0.77 !211003 Ksta0.77
+!       alb_new(1 : knon)  = 0.8 !KstaTER0.8 & LMD_ARMIP5
+!IM: KstaTER0.77 & LMD_ARMIP6    
+
+! Attantion: alb_new and alblw are the same!
+    alb_new(1:knon)  = 0.77
+    alblw(1:knon)    = alb_new(1:knon)
+
+
+!****************************************************************************************
+! Rugosity
+!
+!****************************************************************************************
+    z0_new(:) = rugoro(:)
+
+
+!****************************************************************************************
+! Return the pourcentage for this sub-surface
+!
+!****************************************************************************************
+    pctsrf_lic(:) = pctsrf(:,is_lic)
+    
+
+!****************************************************************************************
+! Send run-off on land-ice to coupler if coupled ocean.
+! run_off_lic has been calculated in fonte_neige
+!
+!****************************************************************************************
+    IF (ocean=='couple') THEN
+       CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic)
+    ENDIF
+
+
+  END SUBROUTINE surf_landice
+!
+!****************************************************************************************
+!
+END MODULE surf_landice_mod
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_ocean_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_ocean_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_ocean_mod.F90	(revision 984)
@@ -0,0 +1,164 @@
+!
+! $Header$
+!
+MODULE surf_ocean_mod
+
+  USE dimphy
+  USE surface_data, ONLY     : ocean
+  USE ocean_forced_mod, ONLY : ocean_forced_noice
+  USE ocean_slab_mod, ONLY   : ocean_slab_noice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_noice
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_ocean(rlon, rlat, sollw, albedo, &
+       rugos, windsp, rmu0, &
+       fder, &
+       itime, dtime, jour, knon, knindex, &
+       debut, swdown, &
+       p1lay, tq_cdrag, coefm, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, agesno, &
+       z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, 
+! slab or couple). The calculations of albedo and rugosity for the ocean surface are 
+! done in here because they are identical for the different modes of ocean. 
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    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)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: coefm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+    LOGICAL, INTENT(IN)                      :: debut
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow, qsurf
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    REAL, DIMENSION(klon) :: alb_eau
+
+! End definition
+!****************************************************************************************
+! 
+! Switch according to type of ocean (couple, slab or forced)
+!****************************************************************************************
+    SELECT CASE(ocean)
+    CASE('couple')
+       CALL ocean_cpl_noice(&
+            sollw, albedo, &
+            windsp, &
+            fder, & 
+            itime, dtime, knon, knindex, &
+            swdown, &
+            p1lay, tq_cdrag, precip_rain, precip_snow,temp_air,spechum,&
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, pctsrf, &
+            radsol, snow, qsurf, agesno, &
+            evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+
+    CASE('slab')
+       CALL ocean_slab_noice(&
+            dtime, knon, knindex, &
+            p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, &
+            radsol, snow, qsurf, agesno, &
+            evap, fluxsens, fluxlat, &
+            tsurf_new, &
+            dflux_s, dflux_l, pctsrf_oce)
+       
+    CASE('force')
+       CALL ocean_forced_noice(itime, dtime, jour, knon, knindex, &
+            debut, &
+            p1lay, tq_cdrag, precip_rain, precip_snow, &
+            temp_air, spechum, &
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, &
+            radsol, snow, qsurf, &
+            agesno, &
+            evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+    END SELECT
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN
+       CALL alboc(FLOAT(jour),rlat,alb_eau)
+    ELSE  ! diurnal cycle
+       CALL alboc_cd(rmu0,alb_eau)
+    ENDIF
+
+    DO i =1, knon
+       alb_new(i) = alb_eau(knindex(i))
+    ENDDO
+
+!****************************************************************************************
+! Calculate the rugosity
+!
+!****************************************************************************************
+    z0_new = SQRT(rugos**2 + rugoro**2)
+
+    ! The rugosity is recalculated with another method
+    z0_new(:) = 0.0
+    DO i = 1, knon
+       z0_new(i) = 0.018*coefm(i) * (u1_lay(i)**2+v1_lay(i)**2)/RG  &
+            +  0.11*14e-6 / SQRT(coefm(i) * (u1_lay(i)**2+v1_lay(i)**2))
+       z0_new(i) = MAX(1.5e-05,z0_new(i))
+    ENDDO
+    
+    alblw(1:knon) = alb_new(1:knon)
+!
+!****************************************************************************************
+!    
+  END SUBROUTINE surf_ocean
+!
+!****************************************************************************************
+!
+END MODULE surf_ocean_mod
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_seaice_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_seaice_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surf_seaice_mod.F90	(revision 984)
@@ -0,0 +1,133 @@
+!
+! $Header$
+!
+MODULE surf_seaice_mod
+
+  USE dimphy
+  USE surface_data, ONLY     : ocean
+  USE ocean_slab_mod, ONLY   : ocean_slab_ice
+  USE ocean_forced_mod, ONLY : ocean_forced_ice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_ice
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_seaice( & 
+       rlon, rlat, sollw, albedo, &
+       fder, &
+       itime, dtime, jour, knon, knindex, &
+       debut, lafin, swdown, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, 
+! slab or couple). The calculation of rugosity for the sea-ice surface is also done
+! in here because it is the same calculation for the different modes of ocean.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: debut, lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsurf, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! End definitions
+!****************************************************************************************
+
+!****************************************************************************************
+! Switch according to type of ocean (couple, slab or forced)
+!
+!****************************************************************************************
+    SELECT CASE(ocean)
+    CASE('couple')
+       CALL ocean_cpl_ice( &
+          rlon, rlat, sollw, albedo, & 
+          fder, & 
+          itime, dtime, knon, knindex, &
+          lafin,&
+          swdown, &
+          p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, pctsrf, &
+          radsol, snow, qsurf, &
+          alblw, evap, fluxsens, fluxlat, &
+          tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+
+    CASE('slab')
+       CALL ocean_slab_ice( & 
+          itime, dtime, jour, knon, knindex, &
+          debut, &
+          tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, &
+          radsol, snow, qsurf, qsol, agesno, &
+          tsoil, &
+          alblw, evap, fluxsens, fluxlat, &
+          tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+    
+    CASE('force')
+       CALL ocean_forced_ice(itime, dtime, jour, knon, knindex, &
+          debut, &
+          tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, &
+          radsol, snow, qsurf, qsol, agesno, &
+          tsoil, alblw, evap, fluxsens, fluxlat, &
+          tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+    END SELECT
+
+!****************************************************************************************
+! Calculate rugosity
+!
+!****************************************************************************************
+    z0_new = 0.002
+    z0_new = SQRT(z0_new**2+rugoro**2)
+
+
+  END SUBROUTINE surf_seaice
+!
+!****************************************************************************************
+!
+END MODULE surf_seaice_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surface_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surface_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/surface_data.F90	(revision 984)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!
+MODULE surface_data
+
+  USE dimphy, ONLY : klon
+
+  REAL, PARAMETER        :: calice=1.0/(5.1444e+06*0.15)
+  REAL, PARAMETER        :: tau_gl=86400.*5.
+  REAL, PARAMETER        :: calsno=1./(2.3867e+06*.15)
+  
+  LOGICAL, SAVE          :: ok_veget       ! true for use of vegetation model ORCHIDEE
+  !$OMP THREADPRIVATE(ok_veget)
+  CHARACTER(len=6), SAVE :: ocean          ! force/slab/couple
+  !$OMP THREADPRIVATE(ocean)
+
+END MODULE surface_data
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tetalevel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tetalevel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tetalevel.F	(revision 984)
@@ -0,0 +1,141 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE tetalevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+c
+cym#include "paramet.h"
+c
+      INTEGER,ALLOCATABLE,SAVE :: lt(:), lb(:)
+      REAL,ALLOCATABLE,SAVE    :: aist(:), aisb(:)
+      REAL,SAVE :: ptop, pbot 
+      LOGICAL,SAVE :: first = .TRUE.
+c$OMP THREADPRIVATE(lt,lb,aist,aisb,ptop, pbot,first)
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+      IF (first) THEN
+        ALLOCATE(lt(ilon), lb(ilon))
+	ALLOCATE(aist(ilon), aisb(ilon))
+	
+	first=.FALSE.
+      ENDIF
+c=====================================================================
+      if (lnew) then
+c   on r�nitialise les r�ndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Fr��ic Hourdin (3/01/02)
+
+c       IF(pgcm(i,lb(i)).NE.0.OR.
+c    $     pgcm(i,lt(i)).NE.0.) THEN
+c
+c       PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+c    .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/thermcell.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/thermcell.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/thermcell.F	(revision 984)
@@ -0,0 +1,1394 @@
+!
+! $Header$
+!
+
+      SUBROUTINE thermcell(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Reecriture a partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est suppose homogene et dissipe par melange avec
+c   son environnement. la longueur l_mix controle l'efficacite du
+c   melange
+c
+c   Le calcul du transport des differentes especes se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real,allocatable,save :: thetath2(:,:),wth2(:,:)
+c$OMP THREADPRIVATE(thetath2,wth2)
+cym      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+c$OMP THREADPRIVATE(first)
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+      logical,save :: firstCall=.true.
+c$OMP THREADPRIVATE(firstCall)
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+      if (firstcall) then
+        allocate(thetath2(klon,klev),wth2(klon,klev))
+	thetath2(:,:)=0.
+	wth2(:,:)=0.
+	firstcall=.false.
+      endif
+      
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                           (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est egale a la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concerne  par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+c#define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+
+      subroutine dqthermcell(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,q,dq,qa)
+      use dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+               qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+       use dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev)
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itere sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+c              gamma0=0.
+c   la premiere fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*u(ig,k)
+            wvd(ig,k)=fm(ig,k)*v(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*u(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*v(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac
+     .    ,q,dq,qa)
+      use dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay),frac(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+      real qe(klon,klev),zf,zf2
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+         qe(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+               zf=0.5*(frac(ig,k)+frac(ig,k+1))
+               zf2=1./(1.-zf)
+               qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2)
+               qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2
+            else
+               qa(ig,k)=q(ig,k)
+               qe(ig,k)=q(ig,k)
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*qe(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      use dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),zf,zf2
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real ue(klon,klev),ve(klon,klev)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itere sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+     s         *1.
+c    s         *0.5
+c              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+c   la premiere fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+c   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+c   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/thermcell.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/thermcell.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/thermcell.h	(revision 984)
@@ -0,0 +1,13 @@
+!
+! $Header$
+!
+
+      integer iflag_thermals,nsplit_thermals
+      real r_aspect_thermals,l_mix_thermals,tho_thermals
+      integer w2di_thermals,isplit
+
+      common/ctherm/iflag_thermals,nsplit_thermals
+     s              ,r_aspect_thermals,l_mix_thermals,tho_thermals
+     s              ,w2di_thermals
+
+c$OMP THREADPRIVATE(/ctherm/)
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tilft43.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tilft43.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tilft43.F	(revision 984)
@@ -0,0 +1,95 @@
+!
+! $Header$
+!
+        SUBROUTINE TLIFT43(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
+        REAL GZ(ND),TPK(ND),CLW(ND),P(ND)
+        REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c -- sb:
+c!      CPD=1005.7
+c!      CPV=1870.0
+c!      CL=4190.0
+c!      RV=461.5
+c!      RD=287.04
+c!      LV0=2.501E6
+c!      G=9.8
+c!      ROWL=1000.0
+c ajouts:
+#include "YOMCST.h"
+        CPD = RCPD
+        CPV = RCPV
+        CL = RCW
+        LV0 = RLVTT
+        G = RG
+        ROWL= RATM/100.
+        GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+C sb --
+C
+        CPVMCL=CL-CPV
+        EPS=RD/RV
+        EPSI=1./EPS
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*(LV0-CPVMCL*(
+     1   T(NK)-273.15))+GZ(NK)
+        CPP=CPD*(1.-Q(NK))+Q(NK)*CPV
+        CPINV=1./CPP
+C
+        IF(KK.EQ.1)THEN
+C
+C   ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
+C
+        DO 50 I=1,ICB-1
+         CLW(I)=0.0
+   50   CONTINUE
+        DO 100 I=NK,ICB-1
+         TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV
+         TVP(I)=TPK(I)*(1.+Q(NK)*EPSI)
+  100   CONTINUE
+        END IF
+C
+C    ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
+C
+        NST=ICB
+        NSB=ICB
+        IF(KK.EQ.2)THEN  
+         NST=NL
+         NSB=ICB+1
+        END IF
+        DO 300 I=NSB,NST
+         TG=T(I)
+         QG=QS(I)
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         DO 200 J=1,2
+          S=CPD+ALV*ALV*QG/(RV*T(I)*T(I))
+          S=1./S
+          AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I)
+          TG=TG+S*(AH0-AHG)
+          TG=MAX(TG,35.0)
+          TC=TG-273.15
+          DENOM=243.5+TC
+          IF(TC.GE.0.0)THEN  
+           ES=6.112*EXP(17.67*TC/DENOM)
+          ELSE  
+           ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+          END IF  
+          QG=EPS*ES/(P(I)-ES*(1.-EPS))
+  200    CONTINUE
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD
+         CLW(I)=Q(NK)-QG
+         CLW(I)=MAX(0.0,CLW(I))
+         RG=QG/(1.-Q(NK))
+         TVP(I)=TPK(I)*(1.+RG*EPSI)
+  300   CONTINUE
+
+c -- sb:
+        RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+c sb --
+
+        RETURN
+        END
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tlift.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tlift.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/tlift.F	(revision 984)
@@ -0,0 +1,245 @@
+!
+! $Header$
+!
+        SUBROUTINE TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,
+     .                  TVP,TPK,CLW,ND,NL,
+     .                  DTVPDT1,DTVPDQ1)
+C
+C     Argument NK ajoute (jyg) = Niveau de depart de la
+C     convection
+C
+        PARAMETER (NA=60)
+        REAL GZ(ND),TPK(ND),CLW(ND)
+        REAL T(ND),RR(ND),RS(ND),TVP(ND),P(ND)
+        REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                   temperature wrt T1 and Q1
+C
+        REAL CLW_NEW(NA),QI(NA)
+        REAL DTPDT1(NA),DTPDQ1(NA)      ! Derivatives of parcel temperature
+C                                   wrt T1 and Q1
+ 
+C
+        LOGICAL ICE_CONV
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c sb        CPD=1005.7
+c sb      CPV=1870.0
+c sb        CL=4190.0
+c sb        CPVMCL=2320.0
+c sb        RV=461.5
+c sb        RD=287.04
+c sb        EPS=RD/RV
+c sb        ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CI=2090.0
+c sb      CPVMCL=CL-CPV
+c sb      CLMCI=CL-CI
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+c sb      ALF0=3.34E+05
+ 
+cccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+       GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CI = RCS
+       CPVMCL = CL-CPV
+       CLMCI = CL-CI
+       EPS = RD/RV
+       ALV0 = RLVTT
+       ALF0 = RLMLT ! (ALF0 = RLSTT-RLVTT)
+c 
+cccccccccccccccccccccc
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        ICB1=MAX(ICB,2)
+        ICB1=MIN(ICB,NL)
+C
+Cjyg1
+CC      CPP=CPD*(1.-RR(1))+RR(1)*CPV
+      CPP=CPD*(1.-RR(NK))+RR(NK)*CPV
+Cjyg2
+      CPINV=1./CPP
+Cjyg1
+C         ICB may be below condensation level
+CCC        DO 100 I=1,ICB1-1
+CCC         TPK(I)=T(1)-GZ(I)*CPINV
+CCC         TVP(I)=TPK(I)*(1.+RR(1)/EPS)
+        DO 50 I=1,ICB1
+         CLW(I)=0.0
+50      CONTINUE
+C
+        DO 100 I=NK,ICB1
+         TPK(I)=T(NK)-(GZ(I) - GZ(NK))*CPINV
+Cjyg1
+CCC         TVP(I)=TPK(I)*(1.+RR(NK)/EPS)
+         TVP(I)=TPK(I)*(1.+RR(NK)/EPS-RR(NK))
+Cjyg2
+         DTVPDT1(I) = 1.+RR(NK)/EPS-RR(NK)
+         DTVPDQ1(I) = TPK(I)*(1./EPS-1.)
+C
+Cjyg2
+ 
+  100   CONTINUE
+ 
+C
+C    ***  FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO    ***
+C
+Cjyg1
+CC        AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1)
+CC     $     +RR(1)*(ALV0-CPVMCL*(T(1)-273.15))
+        AH0=(CPD*(1.-RR(NK))+CL*RR(NK))*T(NK)
+     $     +RR(NK)*(ALV0-CPVMCL*(T(NK)-273.15)) + GZ(NK)
+Cjyg2
+C
+Cjyg1
+        IMIN = ICB1
+C         If ICB is below LCL, start loop at ICB+1
+        IF (PLCL .LT. P(ICB1)) IMIN = MIN(IMIN+1,NL)
+C
+CCC        DO 300 I=ICB1,NL
+        DO 300 I=IMIN,NL
+Cjyg2
+         ALV=ALV0-CPVMCL*(T(I)-273.15)
+         ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        RG=RS(I)
+        TG=T(I)
+C       S=CPD+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg1
+CC        S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I))
+        S=CPD*(1.-RR(NK))+CL*RR(NK)+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg2
+        S=1./S
+ 
+        DO 200 J=1,2
+Cjyg1
+CC         AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I)
+         AHG=CPD*TG+(CL-CPD)*RR(NK)*TG+ALV*RG+GZ(I)
+Cjyg2
+        TG=TG+S*(AH0-AHG)
+        TC=TG-273.15
+        DENOM=243.5+TC
+        DENOM=MAX(DENOM,1.0)
+C
+C       FORMULE DE BOLTON POUR PSAT
+C
+        ES=6.112*EXP(17.67*TC/DENOM)
+        RG=EPS*ES/(P(I)-ES*(1.-EPS))
+ 
+ 
+  200   CONTINUE
+ 
+Cjyg1
+CC        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1))
+        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(NK))
+Cjyg2
+C       TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD
+ 
+Cjyg1
+CC        CLW(I)=RR(1)-RG
+        CLW(I)=RR(NK)-RG
+Cjyg2
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+RG/EPS)
+        TVP(I)=TPK(I)*(1.+RG/EPS-RR(NK))
+Cjyg2
+C
+Cjyg1       Derivatives
+C
+        DTPDT1(I) = CPD*S
+        DTPDQ1(I) = ALV*S
+C
+         DTVPDT1(I) = DTPDT1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) )
+        DTVPDQ1(I) = DTPDQ1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) ) - TPK(I)
+C
+Cjyg2
+ 
+  300   CONTINUE
+C
+      ICE_CONV = .FALSE.
+
+      IF (ICE_CONV) THEN
+C
+CJAM
+C       RAJOUT DE LA PROCEDURE ICEFRAC
+C
+c sb        CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL)
+ 
+        DO 400 I=ICB1,NL
+        IF (T(I).LT.263.15) THEN
+        TG=TPK(I)
+        TC=TPK(I)-273.15
+        DENOM=243.5+TC
+        ES=6.112*EXP(17.67*TC/DENOM)
+        ALV=ALV0-CPVMCL*(T(I)-273.15)
+        ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        DO J=1,4
+        ESI=EXP(23.33086-(6111.72784/TPK(I))+0.15215*LOG(TPK(I)))
+        QSAT_NEW=EPS*ESI/(P(I)-ESI*(1.-EPS))
+CCC        SNEW= CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+        SNEW= CPD*(1.-RR(NK))+CL*RR(NK)
+     .        +ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+C
+        SNEW=1./SNEW
+        TPK(I)=TG+(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+c@$$        PRINT*,'################################'
+c@$$        PRINT*,TPK(I)
+c@$$        PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+        ENDDO
+CCC        CLW(I)=RR(1)-QSAT_NEW
+        CLW(I)=RR(NK)-QSAT_NEW
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS)
+        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS-RR(NK))
+Cjyg2
+        ELSE
+        CONTINUE
+        ENDIF
+ 
+  400   CONTINUE
+C
+      ENDIF
+C
+ 
+******************************************************
+** BK :  RAJOUT DE LA TEMPERATURE DES ASCENDANCES
+**   NON DILUES AU  NIVEAU KLEV = ND
+**   POSONS LE ENVIRON EGAL A CELUI DE KLEV-1
+********************************************************
+ 
+      TPK(NL+1)=TPK(NL)
+ 
+*******************************************************
+
+      RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+ 
+ 
+        RETURN
+        END
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/transp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/transp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/transp.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE transp (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c 
+       USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), e
+c     ------------------------------------------------------------------
+      DO i = 1, klon
+         utran_e(i) = 0.0
+         utran_q(i) = 0.0
+         vtran_e(i) = 0.0
+         vtran_q(i) = 0.0
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i)=utran_q(i)+ u(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/transp_lay.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/transp_lay.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/transp_lay.F	(revision 984)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE transp_lay (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon,klev), utran_q(klon,klev)
+      REAL vtran_e(klon,klev), vtran_q(klon,klev)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), esh
+c     ------------------------------------------------------------------
+      DO l = 1, klev
+      DO i = 1, klon
+         utran_e(i,l) = 0.0
+         utran_q(i,l) = 0.0
+         vtran_e(i,l) = 0.0
+         vtran_q(i,l) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         esh = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i,l)=utran_e(i,l)+ u(i,l)*esh*
+     .                (paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i,l)=utran_q(i,l)+ u(i,l)*q(i,l)
+     .                *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i,l)=vtran_e(i,l)+ v(i,l)*esh*
+     .                (paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i,l)=vtran_q(i,l)+ v(i,l)*q(i,l)
+     .                *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/undefSTD.F	(revision 984)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+      SUBROUTINE undefSTD(nlevSTD,itap,tlevSTD,
+     $           dtime,ecrit_hf,
+     $           oknondef,tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) 
+c          ou la variable tlevSTD est bien definie (.NE.1.E+20), 
+c et 
+c        * de la somme de tlevSTD => tsumSTD
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c        ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c        ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+c
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c variables Input
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime, ecrit_hf
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+c
+c variables Output
+      REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
+      LOGICAL oknondef(klon,klevSTD,nout)
+      REAL tnondef(klon,klevSTD,nout)
+c
+c calcul variables tous les pas de temps de la physique 
+c
+      DO k=1, nlevSTD
+       DO i=1, klon
+        IF(tlevSTD(i,k).EQ.1E+20) THEN
+         IF(oknondef(i,k,1)) THEN          
+          tnondef(i,k,1)=tnondef(i,k,1)+1.
+         ENDIF !oknondef(i,k)
+c
+         IF(oknondef(i,k,2)) THEN          
+          tnondef(i,k,2)=tnondef(i,k,2)+1.
+         ENDIF !oknondef(i,k)
+c
+        ELSE IF(tlevSTD(i,k).NE.1E+20) THEN
+         tsumSTD(i,k,1)=tsumSTD(i,k,1)+tlevSTD(i,k)
+         tsumSTD(i,k,2)=tsumSTD(i,k,2)+tlevSTD(i,k)
+        ENDIF 
+       ENDDO !i
+      ENDDO !k
+c
+c calcul variables toutes les 6h
+c
+      IF(MOD(itap,NINT(ecrit_hf/dtime)).EQ.0) THEN
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tlevSTD(i,k).EQ.1E+20) THEN
+          IF(oknondef(i,k,3)) THEN          
+           tnondef(i,k,3)=tnondef(i,k,3)+1.
+          ENDIF !oknondef(i,k)
+c
+         ELSE IF(tlevSTD(i,k).NE.1E+20) THEN
+         tsumSTD(i,k,3)=tsumSTD(i,k,3)+tlevSTD(i,k)
+         ENDIF 
+        ENDDO !i
+       ENDDO !k
+
+      ENDIF !MOD(itap,NINT(ecrit_hf/dtime)).EQ.0
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ustarhb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ustarhb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/ustarhb.F	(revision 984)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE ustarhb(knon,u,v,cd_m, ustar)
+      use dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+      REAL ustar(klon)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      DO i = 1, knon
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+c       print*,'Ust ',zxu,zxmod,taux,ustar(i)
+      ENDDO
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/vdif_kcay.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/vdif_kcay.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/vdif_kcay.F	(revision 984)
@@ -0,0 +1,743 @@
+!
+! $Header$
+!
+      SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c 
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),q2s(klon,klev+1)
+      REAL q2diag(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon)
+
+      integer l_mix,iii
+c.......................................................................
+c
+c nlay : nombre de couches        
+c nlev : nombre de niveaux
+c ngrid : nombre de points de grille       
+c unsdz : 1 sur l'epaisseur de couche
+c unsdzdec : 1 sur la distance entre le centre de la couche et le
+c            centre de la couche inferieure
+c q : echelle de vitesse au bas de chaque couche
+c     (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      INTEGER nlay,nlev,ngrid
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+      REAL q(klon,klev+1)
+
+c.......................................................................
+c
+c kmpre : km au debut du pas de temps
+c qcstat : q : solution stationnaire du probleme couple
+c          (valeur a la fin du pas de temps)
+c q2cstat : q2 : solution stationnaire du probleme couple
+c           (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL kmpre(klon,klev+1)
+      REAL qcstat
+      REAL q2cstat
+      real sss,sssq
+c.......................................................................
+c
+c long : longueur de melange calculee selon Blackadar
+c
+c.......................................................................
+      REAL long(klon,klev+1)
+c.......................................................................
+c
+c kmq3 : terme en q^3 dans le developpement de km
+c        (valeur au debut du pas de temps)
+c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c knq3 : terme en q^3 dans le developpement de kn
+c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+c          (valeur a la fin du pas de temps)
+c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c m : valeur a la fin du pas de temps
+c mpre : valeur au debut du pas de temps
+c m2 : valeur a la fin du pas de temps
+c n2 : valeur a la fin du pas de temps
+c 
+c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(klon,klev+1)
+      REAL mpre(klon,klev+1)
+      REAL m2(klon,klev+1)
+      REAL n2(klon,klev+1)
+c.......................................................................
+c
+c gn : intermediaire pour les coefficients de stabilite
+c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+c gnmax : borne superieure de gn (0.0233)
+c gninf : vrai si gn est en dessous de sa borne inferieure
+c gnsup : vrai si gn est en dessus de sa borne superieure
+c gm : drole d'objet bien utile
+c ri : nombre de Richardson
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c sm : coefficient de stabilite pour m
+c smq2 : premier terme du developement limite de sm en q2
+c
+c.......................................................................
+      REAL gn
+      REAL gnmin
+      REAL gnmax
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+c      REAL ri(klon,klev+1)
+      REAL sn(klon,klev+1)
+      REAL snq2(klon,klev+1)
+      REAL sm(klon,klev+1)
+      REAL smq2(klon,klev+1)
+c.......................................................................
+c
+c kappa : consatnte de Von Karman (0.4)
+c long00 : longueur de reference pour le calcul de long (160)
+c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+c cn1,cn2 : constantes pour sn
+c cm1,cm2,cm3,cm4 : constantes pour sm
+c
+c.......................................................................
+      REAL kappa
+      REAL long00
+      REAL a1,a2,b1,b2,c1
+      REAL cn1,cn2
+      REAL cm1,cm2,cm3,cm4
+c.......................................................................
+c
+c termq : termes en $q$ dans l'equation de q2
+c termq3 : termes en $q^3$ dans l'equation de q2
+c termqm2 : termes en $q*m^2$ dans l'equation de q2
+c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+c
+c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+c.......................................................................
+c
+c q2min : borne inferieure de q2
+c q2max : borne superieure de q2
+c
+c.......................................................................
+      REAL q2min
+      REAL q2max
+c.......................................................................
+c knmin : borne inferieure de kn
+c kmmin : borne inferieure de km
+c.......................................................................
+      REAL knmin
+      REAL kmmin
+c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+c.......................................................................
+      PARAMETER (kappa=0.4E+0)
+      PARAMETER (long00=160.E+0)
+c     PARAMETER (gnmin=-10.E+0)
+      PARAMETER (gnmin=-0.28)
+      PARAMETER (gnmax=0.0233E+0)
+      PARAMETER (a1=0.92E+0)
+      PARAMETER (a2=0.74E+0)
+      PARAMETER (b1=16.6E+0)
+      PARAMETER (b2=10.1E+0)
+      PARAMETER (c1=0.08E+0)
+      PARAMETER (knmin=1.E-5)
+      PARAMETER (kmmin=1.E-5)
+      PARAMETER (q2min=1.e-5)
+      PARAMETER (q2max=1.E+2)
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+c
+      PARAMETER (
+     &  cn1=a2*(1.E+0 -6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cn2=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1)
+     &          -3.E+0 *c1*(b2+6.E+0 *a1)))
+     &          )
+      PARAMETER (
+     &  cm3=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm4=-9.E+0 *a1*a2
+     &          )
+
+      logical first
+      save first
+      data first/.true./
+c$OMP THREADPRIVATE(first)
+c.......................................................................
+c  traitment des valeur de q2 en entree
+c.......................................................................
+c
+c   Initialisation de q2
+      nlay=klev
+      nlev=klev+1
+       
+      call yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar
+     s   ,l_mix)
+      if (first.and.1.eq.1) then
+      first=.false.
+      q2=q2diag
+      endif
+
+      DO ilev=1,nlev
+                                                      DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+                                                      ENDDO
+      ENDDO
+c
+                                                      DO igrid=1,ngrid 
+      tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+      q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+      q2(igrid,1)=amax1(q2(igrid,1),q2min)
+      q(igrid,1)=sqrt(q2(igrid,1))
+                                                      ENDDO
+c
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO igrid=1,ngrid 
+            zlev(igrid,nlev)=zlay(igrid,nlay)
+     &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+                                                      ENDDO            
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO ilay=1,nlay
+                                                      DO igrid=1,ngrid 
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+                                                      ENDDO
+      DO ilay=2,nlay
+                                                      DO igrid=1,ngrid 
+        unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+                                                      ENDDO
+c
+c.......................................................................
+c  le cisaillement et le gradient de temperature
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,1)=(unsdzdec(igrid,1)
+     &                   *u(igrid,1))**2
+     &                 +(unsdzdec(igrid,1)
+     &                   *v(igrid,1))**2
+      m(igrid,1)=sqrt(m2(igrid,1))
+      mpre(igrid,1)=m(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)
+     &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))
+     &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+c       n2(igrid,ilev)=0.
+c
+c --->
+c       on ne sais traiter que les cas stratifies. et l'ajustement
+c       convectif est cense faire en sorte que seul des configurations
+c       stratifiees soient rencontrees en entree de cette routine.
+c       mais, bon ... on sait jamais (meme on sait que n2 prends
+c       quelques valeurs negatives ... parfois) alors : 
+c<---
+c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)
+     &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2
+     &                   +(unsdzdec(igrid,ilev)
+     &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,nlev)=m2(igrid,nlev-1)
+      m(igrid,nlev)=m(igrid,nlev-1)
+      mpre(igrid,nlev)=m(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  calcul des fonctions de stabilite
+c.......................................................................
+c
+      if (l_mix.eq.4) then
+                                                      DO igrid=1,ngrid 
+         sqz(igrid)=1.e-10
+         sq(igrid)=1.e-10
+                                                      ENDDO
+         do ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+           zq=sqrt(q2(igrid,ilev))
+           sqz(igrid)
+     .     =sqz(igrid)+zq*zlev(igrid,ilev)
+     .     *(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+           sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+                                                      ENDDO
+         enddo
+                                                      DO igrid=1,ngrid 
+         long0(igrid)=0.2*sqz(igrid)/sq(igrid)
+                                                      ENDDO
+      else if (l_mix.eq.3) then
+         long0(igrid)=long00
+      endif
+
+c (abd 5 2)      print*,'LONG0=',long0
+
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        if (l_mix.ge.10) then
+            long(igrid,ilev)=l_mix
+        else
+           long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid))
+        endif
+        long(igrid,ilev)=max(min(long(igrid,ilev)
+     s    ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10)))
+     s    ,5.)
+
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * m2(igrid,ilev)
+c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)
+     &     *(1.E+0 +cm4*gn) )
+c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=
+     &     -gn
+     &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=
+     &     -gn
+     &     *( cm2*(1.E+0 +cm3*gn)
+     &           *(1.E+0 +cm4*gn)
+     &       -( cm3*(1.E+0 +cm4*gn)
+     &         +cm4*(1.E+0 +cm3*gn) )
+     &       *(cm1+cm2*gn)            )
+     &     /( (1.E+0 +cm3*gn)
+     &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+c
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c --->
+c       la decomposition de Taylor en q2 n'a de sens que
+c       dans les cas stratifies ou sn et sm sont quasi
+c       proportionnels a q2. ailleurs on laisse le meme
+c       algorithme car l'ajustement convectif fait le travail.
+c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+c       signe : dans ces cas, on ne fait pas la decomposition.
+c<---
+c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)
+     &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)
+     &      smq2(igrid,ilev)=0.E+0
+c
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde       print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+c.......................................................................
+c  calcul de km et kn au debut du pas de temps
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      kmpre(igrid,1)=km(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+      kmpre(igrid,nlev)=km(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  boucle sur les niveaux 2 a nlev-1
+c.......................................................................
+c
+c---->
+      DO 10001 ilev=2,nlev-1
+c---->
+      DO 10002 igrid=1,ngrid 
+c
+c.......................................................................
+c
+c  calcul des termes sources et puits de l'equation de q2
+c  ------------------------------------------------------
+c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)
+     &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)
+     &                                    /sm(igrid,ilev)
+c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2
+     &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+     &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2
+     &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+c 
+        termq=termq
+     &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)
+     &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3
+     &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+c
+        termq3=termq3
+     &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+c
+c.......................................................................
+c
+c  resolution stationnaire couplee avec le gradient de vitesse local
+c  -----------------------------------------------------------------
+c
+c  -----{on cherche le cisaillement qui annule l'equation de q^2
+c        supposee en q3}
+c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)
+     &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+
+c  abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)
+     &              *cd(igrid)
+     &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)
+     &                -mcstat/unsdzdec(igrid,ilev)
+     &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)
+     &                          *mpre(igrid,ilev-1) )
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat
+     &      /( sm(igrid,ilev)/q2(igrid,ilev) )
+     &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+c
+c.......................................................................
+c
+c  choix de la solution finale
+c  ---------------------------
+c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+c abd       if(ilev.le.57.and.ilev.ge.37) then
+c           print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
+c     s     'N2=',n2(igrid,ilev)
+c abd       endif
+          m2(igrid,ilev)=m2cstat
+c
+c --->
+c       pour des raisons simples q2 est minore 
+c<---
+c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+c
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sm(igrid,ilev)
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c
+c.......................................................................
+c
+10002 CONTINUE
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+c     kn(igrid,1)=cd(igrid)
+c     km(igrid,1)=cd(igrid)
+      q2(igrid,nlev)=q2(igrid,nlev-1)
+      q(igrid,nlev)=q(igrid,nlev-1)
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+                                                      ENDDO
+c
+c  CALCUL DE LA DIFFUSION VERTICALE DE Q2
+      if (1.eq.1) then
+
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+c        print*,'Q2moy avant',sssq/sss
+c       print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
+c       print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
+c   ! C'est quoi ca qu'etait dans l'original???
+c       do igrid=1,ngrid
+c          q2(igrid,1)=10.
+c       enddo
+c        q2s=q2
+c       do iii=1,10
+c       call vdif_q2(dt,g,rconst,plev,temp,km,q2)
+c       do ilev=1,klev+1
+c          write(iii+49,*) q2(1,ilev),zlev(1,ilev)
+c       enddo
+c       enddo
+c       stop
+c       do ilev=1,klev
+c          print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
+c       enddo
+c        q2s=q2-q2s
+c       do ilev=1,klev
+c          print*,q2s(1,ilev),zlev(1,ilev)
+c       enddo
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+        print*,'Q2moy apres',sssq/sss
+c
+c
+        do ilev=1,nlev
+           do igrid=1,ngrid
+              q2(igrid,ilev)=max(q2(igrid,ilev),q2min)
+              q(igrid,ilev)=sqrt(q2(igrid,ilev))
+
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde      print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+c
+           enddo
+        enddo
+c       print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
+
+      endif
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/wrgradsfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/wrgradsfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/wrgradsfi.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      implicit none
+
+c   Declarations
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+
+c   arguments
+      integer if,nl
+      real fieldfi_p(klon,nl)
+      real fieldfi(klon_glo,nl)
+      real fielddyn((iim+1)*(jjm+1),llm)
+      character*10 name
+      character*10 titlevar
+
+c   local
+
+      integer lm,l,lnblnk
+
+
+
+c     print*,'Transformation pour ',name
+      call Gather(fieldfi_p,fieldfi)
+
+c$OMP MASTER      
+      if (is_mpi_root) then
+        call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn)
+        
+c     print*,'Transformation OK '
+        call wrgrads(if,nl,fielddyn,name,titlevar)
+c     print*,'Ecriture ok'
+      endif
+c$OMP END MASTER
+      
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_bilKP_ave.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_bilKP_ave.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_bilKP_ave.h	(revision 984)
@@ -0,0 +1,155 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+      itau_w = itau_phy + itap
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ue",itau_w,ue_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ve",itau_w,ve_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"uq",itau_w,uq_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vq",itau_w,vq_lay)
+c
+c Champs 3D:
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"play",itau_w,paprs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"oliq",itau_w,cldliq)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqdyn",itau_w,d_q_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtcon",itau_w,d_t_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ducon",itau_w,d_u_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvcon",itau_w,d_v_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqcon",itau_w,d_q_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlsc",itau_w,d_t_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqlsc",itau_w,d_q_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqvdf",itau_w,d_q_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtajs",itau_w,d_t_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqajs",itau_w,d_q_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dteva",itau_w,d_t_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqeva",itau_w,d_q_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtswr",itau_w,heat)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtsw0",itau_w,heat0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlwr",itau_w,cool)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlw0",itau_w,cool0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duvdf",itau_w,d_u_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvvdf",itau_w,d_v_vdf)
+c
+      IF (ok_orodr) THEN
+      IF (ok_orolf) THEN
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k)
+        d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k)
+      ENDDO
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duoli",d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvoli",itau_w,d_v_oli)
+c
+      ENDIF
+      ENDIF
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duphy",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvphy",itau_w,d_v)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), 
+cymf     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqphy",itau_w,d_qx(:,:,1))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqlphy",itau_w,d_qx(:,:,2))
+c
+C
+      if (ok_sync) then
+        call histsync(nid_bilKPave)
+      endif
+       ENDIF
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_bilKP_ins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_bilKP_ins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_bilKP_ins.h	(revision 984)
@@ -0,0 +1,179 @@
+ c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ue",itau_w,ue_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ve",itau_w,ve_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"uq",itau_w,uq_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vq",itau_w,vq_lay)
+c
+c Champs 3D:
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"play",itau_w,paprs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"oliq",itau_w,cldliq)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqdyn",itau_w,d_q_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtcon",itau_w,d_t_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ducon",itau_w,d_u_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvcon",itau_w,d_v_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqcon",itau_w,d_q_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlsc",itau_w,d_t_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqlsc",itau_w,d_q_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqvdf",itau_w,d_q_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtajs",itau_w,d_t_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqajs",itau_w,d_q_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dteva",itau_w,d_t_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqeva",itau_w,d_q_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtswr",itau_w,heat)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtsw0",itau_w,heat0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlwr",itau_w,cool)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlw0",itau_w,cool0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duvdf",itau_w,d_u_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvvdf",itau_w,d_v_vdf)
+c
+      IF (ok_orodr) THEN
+      IF (ok_orolf) THEN
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k)
+        d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k)
+      ENDDO
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duoli",itau_w,d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvoli",itau_w,d_v_oli)
+c
+      ENDIF
+      ENDIF
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duphy",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvphy",itau_w,d_v)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqphy",itau_w,d_qx(:,:,1))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqlphy",itau_w,d_qx(:,:,2))
+c
+cIM 280405 BEG
+c
+c Champs 2D:
+c
+c   Ecriture de champs dynamiques sur des niveaux de pression
+c     DO k=1, nlevSTD
+      DO k=1, 12
+c
+       IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+       IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+       IF(bb2.EQ."850") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_bilKPins,"u"//bb2,itau_w,usumSTD(:,k,1))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_bilKPins,"v"//bb2,itau_w,vsumSTD(:,k,1))
+c
+       ENDIF !(bb2.EQ."850")
+c
+       ENDDO !k=1, 12
+c
+cIM 280405 END
+C
+      if (ok_sync) then
+        call histsync(nid_bilKPins)
+      endif
+       ENDIF
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_field_phy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_field_phy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_field_phy.F90	(revision 984)
@@ -0,0 +1,36 @@
+!
+! $Header$
+!
+MODULE write_field_phy
+
+  CONTAINS 
+ 
+    SUBROUTINE WriteField_phy(name,Field,ll)
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE mod_grid_phy_lmdz
+    USE Write_Field
+    
+    IMPLICIT NONE
+    include 'dimensions.h'
+    include 'paramet.h'
+
+    character(len=*)   :: name
+    INTEGER :: ll
+    real, dimension(klon_omp,ll) :: Field
+    real,save,allocatable :: Field_tmp(:,:)
+    real, dimension(klon_glo,ll):: New_Field
+    real, dimension(iim,jjp1,ll):: Field_2d
+
+    CALL Gather(Field,New_Field)
+!$OMP MASTER
+    IF (is_mpi_root) THEN	
+      CALL Grid1Dto2D_glo(New_Field,Field_2D)
+      CALL WriteField(name,Field_2d)
+    ENDIF
+!$OMP END MASTER
+
+  
+   END SUBROUTINE WriteField_phy
+ 
+ END MODULE write_field_phy
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histISCCP.h	(revision 984)
@@ -0,0 +1,208 @@
+!
+! $Header$
+!
+      IF (ok_isccp) THEN
+c
+       ndex2d = 0
+       ndex3d = 0
+c
+       itau_w = itau_phy + itap
+c
+       IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+        DO n=1, napisccp
+c
+        DO k=1,kmaxm1
+         zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1,n)*100.
+cym         CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d,
+cym     .                    zx_tmp_3d)
+c
+cIM: champ 3d : (lon,lat,pres) pour un tau fixe
+c
+       CALL histwrite_phy(nid_isccp,"cldISCCP_"//taulev(k)//verticaxe(n),
+     .                  itau_w,zx_tmp_fi3d)
+        ENDDO !k
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),itau_w,
+     .                 nbsunlit(1,:,n))
+c
+        ENDDO ! n=1, napisccp
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+        DO n=1, napisccp
+c        print*,'n=',n,' write_ISCCP avant fq_isccp'
+         DO k=1, kmaxm1
+          DO l=1, lmaxm1
+c
+         IF(top_height.LE.2) THEN
+          DO i=1, klon
+           IF(nbsunlit(1,i,n).NE.0.) THEN
+            fq_is_true(i,k,l,n)=
+     $      fq_isccp(i,k,l,n)*100./nbsunlit(1,i,n)
+           ELSE
+            fq_is_true(i,k,l,n)=0
+           ENDIF
+          ENDDO 
+         ELSE IF(top_height.EQ.3) THEN 
+          DO i=1, klon
+           fq_is_true(i,k,l,n) = fq_isccp(i,k,l,n)*100.
+          ENDDO
+         ENDIF
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,fq_is_true,
+cym     .                    zx_tmp_2d)
+c
+cIM: champ 2d : (lon,lat) pour un tau et une pc fixes
+c
+         CALL histwrite_phy(nid_isccp,pclev(l)//taulev(k)//verticaxe(n),
+     .                  itau_w,fq_is_true(:,k,l,n))
+         ENDDO !l
+        ENDDO !k
+c
+c       print*,'n=',n,' write_ISCCP avant nbsunlit'
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),
+     .                 itau_w,nbsunlit(1,:,n))
+c
+        zx_tmp_fi2d(1:klon)=float(seed(1:klon,n))
+c
+c       print*,'n=',n,' write_ISCCP avant seed'
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"seed"//verticaxe(n),
+     .                 itau_w,zx_tmp_fi2d)
+c
+c 9types de nuages ISCCP-D2
+c fq_isccp(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +
+     $  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +
+     $  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+        ENDDO
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cirr",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +
+     $   fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +
+     $   fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cist",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +
+     $   fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +
+     $   fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"deep",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +
+     $  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alcu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +
+     $   fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alst",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +
+     $   fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nist",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +
+     $  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cumu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +
+     $   fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stcu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +
+     $   fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stra",itau_w,zx_tmp_fi2d)
+c
+c 3_tau_nuages x 3_levels
+c fq_is_true(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         cld_fi3d(i,1)= 
+     $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +
+     $  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +
+     $  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+	 cld_fi3d(i,2)=
+     $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +
+     $  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+         cld_fi3d(i,3)=
+     $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +
+     $  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO   
+cym        CALL gr_fi_ecrit(lmax3,klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thin",itau_w,cld_fi3d)
+c
+        DO i=1, klon
+	 cld_fi3d(i,1)=
+     $   (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +
+     $    fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +
+     $    fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+	 cld_fi3d(i,2)=
+     $   (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +
+     $    fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+	 cld_fi3d(i,3)=
+     $   (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +
+     $    fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+	ENDDO   
+cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"mid",itau_w,cld_fi3d)
+c
+        DO i=1, klon
+	 cld_fi3d(i,1)=
+     $   (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +
+     $    fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +
+     $    fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+         cld_fi3d(i,2)=
+     $   (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +
+     $    fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+	 cld_fi3d(i,3)=
+     $   (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +
+     $    fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO   
+cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thick",itau_w,cld_fi3d)
+c
+        ENDDO ! n=1, napisccp
+c
+       ENDIF
+c
+       if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_isccp)
+c$OMP END MASTER       
+       endif
+
+      ENDIF !ok_isccp
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histREGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histREGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histREGDYN.h	(revision 984)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      if (ok_regdyn) then
+      
+      if (is_sequential) then
+
+
+      ndex3d = 0
+      itau_w = itau_phy + itap
+c
+       CALL histwrite(nid_regdyn,"hw1",itau_w,histoW(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh1",itau_w,nhistoW(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht1",itau_w,nhistoWt(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw2",itau_w,histoW(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh2",itau_w,nhistoW(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht2",itau_w,nhistoWt(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw3",itau_w,histoW(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh3",itau_w,nhistoW(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht3",itau_w,nhistoWt(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw4",itau_w,histoW(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh4",itau_w,nhistoW(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht4",itau_w,nhistoWt(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw5",itau_w,histoW(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh5",itau_w,nhistoW(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht5",itau_w,nhistoWt(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+
+      if (ok_sync) then
+        call histsync(nid_regdyn)
+      endif
+
+      endif ! is_sequential
+
+      endif
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histday.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histday.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histday.h	(revision 984)
@@ -0,0 +1,576 @@
+c
+c $Header$
+c
+      if (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         itau_w = itau_phy + itap
+
+c
+      IF(lev_histday.GE.1) THEN
+c
+       CALL histwrite_phy(nid_day,"phis",itau_w,pphis)
+ 
+c
+       CALL histwrite_phy(nid_day,"aire",itau_w,airephy)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"contfracATM",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"contfracOR",itau_w,
+     &                   pctsrf_new(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tsol",itau_w,zxtsol)
+C
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m",itau_w,zt2m)
+c
+c   En attendant un eventuel debugage.
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m_min",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m_max",itau_w,zt2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_lsc,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowl",itau_w,snow_lsc)
+c
+      IF(1.EQ.0) THEN
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_con,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowc",itau_w,snow_con)
+      ENDIF
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"flat",itau_w,zxfluxlat)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sicf",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10m",itau_w,zv10m)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)     
+      CALL histwrite_phy(nid_day,"wind10m",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"wind10max",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+         zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowf",itau_w,snow_fall)
+c
+cIM: 140404   CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite(nid_day,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldt",itau_w,cldt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldq",itau_w,cldq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"prw",itau_w,prw)
+
+c   Ecriture de champs dynamiques sur des niveaux de pression
+c     DO k=1, nlevENS
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"u"//bb2,itau_w,usumSTD(:,k,1))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"v"//bb2,itau_w,vsumSTD(:,k,1))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+c w500
+c
+      IF(bb2.EQ."500") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"w"//bb2,itau_w,wsumSTD(:,k,1))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"phi"//bb2,itau_w,phisumSTD(:,k,1))
+
+      ENDIF !(bb2.EQ."500") THEN
+c
+      ENDDO !nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cape_max",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"solldown",itau_w,sollwdown)
+c
+      DO i=1, klon
+        zx_tmp_fi2d(i)=-1*sens(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sens",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn(1 : klon, 1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"lmt_bils",itau_w, zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"slab_bils",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"siceh",itau_w,seaice/1000.)
+c
+      ENDIF !(OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      ENDIF !lev_histday.GE.1
+c
+      IF(lev_histday.GE.2) THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"bils",itau_w, bils)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fder",itau_w,fder)
+c
+      ENDIF !lev_histday.GE.2
+c
+      IF(lev_histday.GE.3) THEN
+c=================================================================
+c   ECRITURE DES CHAMPS 3D
+c=================================================================
+
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"pres",itau_w,pplay)
+c
+      ENDIF !lev_histday.GE.3
+c=================================================================
+c   FIN ECRITURE DES CHAMPS 3D
+c=================================================================
+      IF(lev_histday.ge.4) THEN
+c=================================================================
+c
+c   ECRITURE DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+      zx_tmp_fi2d(1 : klon) = swup( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c 
+      zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c 
+      zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM AMMA-MIP
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"LWdnSFC",itau_w,sollwdown)
+c
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+cIM   IF (iflag_con.GE.3) THEN
+cIM ema_pct= 0.     CALL gr_fi_ecrit(1, klon,iim,jjmp1, ema_pct,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, meanptop(:,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"ptop",itau_w,meanptop(:,1))
+cIM   ENDIF
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"toce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tsic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter_min",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter_max",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2msic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10msic",itau_w,zx_tmp_fi2d)
+C
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10msic",itau_w,zx_tmp_fi2d)
+C
+      DO nsrf = 1, nbsrf
+C
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"pourc_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"fract_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"tsol_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"sens_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C  
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"lat_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"taux_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"tauy_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"albe_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"rugs_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C 
+      END DO  
+c=================================================================
+c   FIN ECRITURE DES CHAMPS SUR LES SOUS SURFACES
+c=================================================================
+      ENDIF !lev_histday.GE.4
+c
+      IF(lev_histday.GE.5) THEN !lev_histday.GE.5
+c
+c rajout sorties F. Aires
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"topl0",itau_w,toplw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"soll0",itau_w, sollw0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"rneb",itau_w,cldfra)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"iwcon",itau_w,fiwc)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, meantaucld,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"meantaucld",itau_w,meantaucld)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldtau,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"cldtau",itau_w,cldtau)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldemi,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"cldemi",itau_w,cldemi)
+c
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"dtcon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"dqcon",itau_w,zx_tmp_fi3d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, zx_tmp_2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"rh2m",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, qsat2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"qsat2m",itau_w,qsat2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, tpot,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tpot",itau_w,tpot)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, tpote,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tpote",itau_w,tpote)
+c
+      ENDIF !lev_histday.GE.5
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_day)
+c$OMP END MASTER
+      endif
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histday_seri.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histday_seri.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histday_seri.h	(revision 984)
@@ -0,0 +1,242 @@
+c
+c $Header$
+c
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+c
+      ndex2d = 0
+      itau_w = itau_phy + itap
+c
+c Champs 2D:
+c
+      pi = ACOS(-1.)
+      pir = 4.0*ATAN(1.0) / 180.0
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=(topsw(i)-toplw(i))
+      ENDDO
+c
+      ok_msk=.FALSE.
+      msk(1:klon)=pctsrf(1:klon,is_ter)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bilTOA",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, bils, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bils",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO k=1, klev
+      DO i=1, klon
+cIM 080904    zx_tmp_fi3d(i,k)=u(i,k)**2+v(i,k)**2
+       zx_tmp_fi3d(i,k)=(u(i,k)**2+v(i,k)**2)/2.
+      ENDDO
+      ENDDO
+c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, 
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"ecin",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+cIM 151004 BEG
+      IF(1.EQ.0) THEN
+c
+      DO k=1, klev
+      DO i=1, klon
+       zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i))
+      ENDDO
+      ENDDO
+c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, 
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+c friction torque
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i))
+      ENDDO
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+c mountain torque
+c
+cIM 190504 BEG
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_dyn(klev+1,klon,iim+1,jjm+1,paprs,padyn)
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,rlat,rlatdyn)
+      mountor=0.
+      airetot=0.
+      DO j = 1, jjmp1
+       DO i = 1, iim+1
+        ij=i+(iim+1)*(j-1)
+        zx_tmp(ij)=0.
+        DO k = 1, klev
+         zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)*
+     $              (padyn(i,j,k+1)-padyn(i,j,k))/RG
+         airetot=airetot+airedyn(i,j)
+        ENDDO
+cIM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA*
+        mountor=mountor+zx_tmp(ij)*RA*
+     $           cos(pir* rlatdyn(i,j))
+       ENDDO
+      ENDDO
+cIM 151004 BEG
+      IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev
+cIM 151004 END
+cIM 190504      mountor=mountor/(airetot*airetot)
+      mountor=mountor/airetot
+c
+cIM 190504 END
+      zx_tmp_2d(1:iim,1:jjmp1)=mountor
+      CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      ENDIF !(1.EQ.0) THEN
+c
+c
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      airetot=0.
+c     DO j = 1, jjmp1
+c      DO i = 1, iim+1
+c       ij=i+(iim+1)*(j-1)
+c       DO k = 1, klev
+c        airetot=airetot+airedyn(i,j)
+c        airetot=airetot+airedyn(i,j)
+c       ENDDO !k
+c      ENDDO !i
+c     ENDDO !j
+c
+      DO i=1, klon
+       airetot=airetot+airephy(i)
+      ENDDO
+c     IF(itap.EQ.1) PRINT*,'airetotphy=',airetot
+c
+      airetot=0.
+      DO j=1, jjmp1
+       DO i=1, iim
+        airetot=airetot+zx_tmp_2d(i,j)
+       ENDDO
+      ENDDO
+c
+c     IF(itap.EQ.1) PRINT*,'airetotij=',airetot,
+c    $ '4piR2',4.*pi*RA*RA
+c
+      zx_tmp_fi2d(1:klon)=aam/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1:klon)=torsfc/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"torsfc",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+cIM 151004 END
+c
+      CALL moyglo_pondmass(klon, klev, t_seri,
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tamv",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, paprs(:,1), airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"psol",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, evap, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"evap",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c     DO i=1, klon
+c      zx_tmp_fi2d(i)=SnowFrac(i,is_ter)
+c     ENDDO
+c
+c     ok_msk=.TRUE.
+c     msk(1:klon)=pctsrf_new(1:klon,is_ter)
+c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+c    .                     ok_msk, msk, moyglo)
+c     zx_tmp_fi2d(1:klon)=moyglo
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+c     CALL histwrite(nid_day_seri,"SnowFrac",
+c    .               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+c     DO i=1, klon
+cIM 080904    zx_tmp_fi2d(i)=zsnow_mass(i)/330.*rowl
+c      zx_tmp_fi2d(i)=zsnow_mass(i)
+c     ENDDO
+c
+cIM 140904   ok_msk=.FALSE.
+c     ok_msk=.TRUE.
+c     msk(1:klon)=pctsrf(1:klon,is_ter)
+c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+c    .     ok_msk, msk, moyglo)
+c     zx_tmp_fi2d(1:klon)=moyglo
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+c     CALL histwrite(nid_day_seri,"snow_depth",itau_w,
+c    .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=ftsol(i,is_oce)
+      ENDDO
+c
+      ok_msk=.TRUE.
+      msk(1:klon)=pctsrf(1:klon,is_oce)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tsol_"//clnsurf(is_oce),
+     $               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_day_seri)
+      endif
+c
+      ENDIF !fin test sur type_run.EQ."AMIP"
+      
+      ENDIF  ! mono_cpu
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histhf.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histhf.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histhf.h	(revision 984)
@@ -0,0 +1,356 @@
+!
+! $Header$
+!
+      if (ok_hf) then
+
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, paire_ter, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"aireTER",itau_w,paire_ter)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"contfracATM",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"contfracOR",itau_w,
+     .                   pctsrf_new(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t2m",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q2m",itau_w,zq2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"precip",itau_w,zx_tmp_fi2d)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"slp",itau_w,slp)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v10m",itau_w,zv10m)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."500") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w, philevSTD(:,k))
+      ENDIF !bb2.EQ."500"
+      ENDDO
+c
+      ENDIF !lev_histhf.GE.1
+c
+      IF(lev_histhf.GE.2) THEN
+c
+cIM 140904 BEG
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = cldt(i)*100.
+      ENDDO
+cIM 140904 END
+cIM 140904   CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cldt",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"SWnetOR",itau_w, zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol(1:klon))
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"SWdownOR",itau_w, zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWdownOR",itau_w,sollwdown) 
+c
+c
+      ENDIF !lev_histhf.GE.2
+c
+      IF(lev_histhf.GE.3) THEN
+c
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t"//bb2,itau_w, tlevSTD(:,k))
+c
+      IF(bb2.NE."500") THEN !bb2.NE."500"
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,philevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w,philevSTD(:,k))
+      ENDIF !bb2.NE."500"
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q"//bb2,itau_w, qlevSTD(:,k))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u"//bb2,itau_w,ulevSTD(:,k))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v"//bb2,itau_w, vlevSTD(:,k))
+c
+      ENDIF !bb2.EQ."850".OR.bb2.EQ."700"
+      ENDDO !nlevENS
+c
+      IF(1.EQ.0) THEN
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cdrh",itau_w,cdragh)
+      ENDIF !(1.EQ.0) THEN
+c
+      ENDIF !lev_histhf.GE.3
+c
+      IF(lev_histhf.GE.4) THEN 
+c
+#undef histhf3d
+#define histhf3d
+#ifdef histhf3d
+#include "write_histhf3d.h"
+#endif
+c
+      ENDIF !lev_histhf.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+      DO k=1, nlevSTD
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+        IF(bb2.EQ."850".or.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"u"//bb2,itau_w,ulevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"v"//bb2,itau_w,vlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."850".or.bb2.EQ."200"
+c
+      ENDDO !nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"topl",itau_w,toplw)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"slp",itau_w,slp)
+c
+cIM 280504 BEG
+      ENDIF !(lev_histhf.GE.1) THEN
+c
+      IF(lev_histhf.GE.2) THEN
+c
+       DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+        IF(bb2.EQ."850".or.bb2.EQ."500") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"t"//bb2,itau_w,tlevSTD(:,k))
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"q"//bb2,itau_w, qlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."850".or.bb2.EQ."500"
+c
+        IF(bb2.EQ."500") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w, philevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, wlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"w"//bb2,itau_w, wlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."500"
+c
+        IF(bb3.EQ."50") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"t"//bb3,itau_w, tlevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"u"//bb3,itau_w, ulevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"v"//bb3,itau_w, vlevSTD(:,k))
+c
+        ENDIF !bb3.EQ."50"
+c
+       ENDDO !k=1, nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v10m",itau_w,zv10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t2m",itau_w, zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q2m",itau_w,zq2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"psol",itau_w,zx_tmp_fi2d)
+c
+cIM 140904 BEG
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = cldt(i)*100.
+      ENDDO
+cIM 140904 END
+cIM 140904   CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cldt",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = zxfluxu(1 : klon, 1)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"taux",itau_w,zx_tmp_fi2d)
+C
+      zx_tmp_fi2d(1 : klon) = zxfluxv(1 : klon, 1)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"tauy",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"prw",itau_w,prw)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"flat",itau_w,zxfluxlat)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_hf,"snow_mass",itau_w,zsnow_mass)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWdnSFC",itau_w,sollwdown)
+c
+cIM 090904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWupSFC",itau_w,zx_tmp_fi2d)                    
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+      IF (is_sequential) THEN
+cym      CALL gr_fi_ecrit(nbteta,klon,iim,jjmp1,PVteta,zx_tmp_3dte)
+      DO k=1, nbteta
+       zx_tmp_fi2d(1:klon) = PVteta(1:klon,k)
+       CALL histwrite_phy(nid_hf,"PV"//ctetaSTD(k),
+     .      itau_w,zx_tmp_fi2d)
+      ENDDO !k=1, nbteta
+      ENDIF
+c
+c
+c planetary boundary layer height
+c
+c     ENDIF !1.EQ.0
+c
+      ENDIF !(lev_histhf.GE.2) THEN
+cIM 280504 END
+c
+      ENDIF !type_run
+c
+      IF (ok_sync) THEN
+c$OMP MASTER
+        call histsync(nid_hf)
+c$OMP END MASTER
+      ENDIF
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histhf3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histhf3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histhf3d.h	(revision 984)
@@ -0,0 +1,28 @@
+
+c
+c $Header$
+c
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"vitv",itau_w,v_seri)
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_hf3d)
+c$OMP END MASTER      
+      endif
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histins.h	(revision 984)
@@ -0,0 +1,234 @@
+!
+! $Header$
+!
+      IF (ok_instan) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+      itau_w = itau_phy + itap
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"phis",itau_w,pphis)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"aire",itau_w,airephy)
+
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"precip",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)    
+      CALL histwrite_phy(nid_ins,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"pluc",itau_w,zx_tmp_fi2d)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"tsol",itau_w,zxtsol)
+cccIM
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"t2m",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"v10m",itau_w,zv10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"snow",itau_w,snow_fall)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"solldown",itau_w,sollwdown)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"fder",itau_w,fder)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfo",itau_w,d_ts(:,is_oce))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdft",itau_w,d_ts(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfg",itau_w, d_ts(:,is_lic))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfi",itau_w,d_ts(:,is_sic))
+
+      DO nsrf = 1, nbsrf
+CXXX
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"pourc_"//clnsurf(nsrf),itau_w,
+     $                zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"tauy_"//clnsurf(nsrf),itau_w,
+     $     zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C 
+      END DO  
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"albs",itau_w,albsol)
+      
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"albslw",itau_w,albsollw)
+
+c
+cIM: 140404   CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_ins,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"rugs",itau_w,zxrugs)
+c
+cIM cf. AM 081204 BEG
+c
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"dqvdf",itau_w,d_q_vdf)
+
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_ins)
+c$OMP END MASTER
+      endif
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histmth.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histmth.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histmth.h	(revision 984)
@@ -0,0 +1,1852 @@
+c
+c $Header$
+c
+      IF (ok_mensuel) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+
+         itau_w = itau_phy + itap
+
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+c Champs 2D:
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phis",itau_w,pphis)
+C
+cIM 310804   CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"aire",itau_w,airephy)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m",itau_w,zt2m)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_min",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_max",itau_w,zt2m)
+c
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"tsoil",itau_w,zx_tmp_2d,
+c    .               iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sicf",itau_w,zx_tmp_fi2d)
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"temp",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+c ENSEMBLES END
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"v10m",itau_w,zv10m)
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"psol",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"qsurf",itau_w,zxqsurf)
+c
+      if (.not. ok_veget) then
+cym          CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d)
+          CALL histwrite_phy(nid_mth,"qsol",itau_w,qsol)
+      endif
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ndayrain",itau_w,nday_rain)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"snow",itau_w,snow_fall)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl0",itau_w,toplw0)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+c
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200",itau_w,SWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200clr",itau_w,SWup200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200",itau_w,SWdn200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200clr",itau_w,SWdn200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200",itau_w,LWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200clr",itau_w,LWup200clr)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200clr",itau_w,zx_tmp_fi2d)
+c
+c200 END 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll0",itau_w,sollw0)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       sollwdownclr(i)=-1.*lwdn0(i,1)
+      ENDDO !i=1, klon
+
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)-sollwdownclr(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFC",itau_w,sollwdown)
+c
+c     DO i=1, klon
+cIM 080904     sollwdownclr(i)=lwdn0(i,1)
+c      sollwdownclr(i)=-1.*lwdn0(i,1)
+c     ENDDO !i=1, klon
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFCclr",itau_w,sollwdownclr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fder",itau_w,fder)
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"ffonte",itau_w,zxffonte)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqcalving",itau_w,zxfqcalving)
+
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqfonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqfonte",itau_w,zxfqfonte)
+
+       DO nsrf = 1, nbsrf
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDDO
+c
+      DO nsrf = 1, nbsrf
+CYYY
+       IF(nsrf.GT.2) THEN
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+       ENDIF !nsrf.GT.2
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       IF(1.EQ.0) THEN
+C
+        zx_tmp_fi2d(1:klon) = fevap(1:klon,nsrf)*pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"evapour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1:klon) = (rain_fall(1:klon) + snow_fall(1:klon))
+     $                        *pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"prepour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       ENDIF !(1.EQ.0) THEN
+C
+      END DO  
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldt",itau_w,cldt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldq",itau_w,cldq)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ue",itau_w,ue)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ve",itau_w,ve)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"uq",itau_w,uq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"vq",itau_w,vq)
+cKE43
+      IF (iflag_con.GE.3) THEN ! sb
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cape",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pbase",itau_w,pbase)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ptop",itau_w,ema_pct)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fbase",itau_w,ema_cbmf)
+c
+c34EK
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"prw",itau_w,prw)
+c
+      ENDIF !iflag_con.GE.3
+c
+c
+cIM cf. AM 081204 BEG
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c  Champs interpolles sur des niveaux de pression
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"u"//bb2,itau_w,usumSTD(:,k,2))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"v"//bb2,itau_w,vsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"w"//bb2,itau_w,wsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phi"//bb2,itau_w,phisumSTD(:,k,2))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+      ENDDO !nlevSTD
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     .     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ 
+     .                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     .                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t_oce_sic",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lmt_bils",itau_w,zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slab_bils",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"siceh",itau_w, seaice/1000.)
+c
+      ENDIF !OCEAN.EQ.force/slab
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+C
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"iwcon",itau_w,fiwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"temp",itau_w,t_seri)
+c
+c#ifdef histmthNMC
+c#include "write_histmthNMC.h"
+c#endif
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ovap",itau_w,qx(:,:,ivap))
+c
+c     zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/
+c    .                         (1-qx(1:klon,1:klev,ivap))
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+c     CALL histwrite(nid_mth,"wvap",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rneb",itau_w,cldfra)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rhum",itau_w,zx_rh)
+
+      DO k=1, klev
+       DO i=1, klon
+cIM 151004      zx_tmp_fi3d(i,k)=MAX(wo(i,k),1.0e-12)*RG/46.6968
+c    $                    /(paprs(i,k)-paprs(i,k+1))
+c    $                    *(paprs(i,1)/101325.0)
+c        zx_tmp2_fi3d(i,k)=MAX(wo(i,k)*1.0e+6,1.0e-6)*RG/46.6968
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp2_fi3d,zx_tmp_3d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ozone",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap), 
+cym     .                 zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqphy",itau_w, d_qx(:,:,ivap))
+cIM 22.03.04 END
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+       DO nsrf=1, nbsrf
+c
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ages_"//clnsurf(nsrf),itau_w
+     $    ,zx_tmp_fi2d)
+c
+      ENDDO !nsrf=1, nbsrf
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albs",itau_w,albsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albslw",itau_w,albsollw)
+c
+      ENDIF !lev_histmth.GE.3
+c
+c
+      IF(lev_histmth.GE.4) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"clwcon",itau_w,clwcon0)
+
+      IF (iflag_con.GE.3) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"Ma",itau_w,Ma)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"upwd",itau_w,upwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd",itau_w,dnwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd0",itau_w,dnwd0)
+c
+      ENDIF !iflag_con.GE.3
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdyn",itau_w,d_q_dyn)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtcon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqcon",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlsc",itau_w,zx_tmp_fi3d)
+cIM: 071003
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     .                             d_t_eva(1:klon,1:klev))/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlschr",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqlsc",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqvdf",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dteva",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqeva",itau_w,zx_tmp_fi3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ptconv",itau_w,zpt_conv)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ratqs",itau_w,ratqs)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtajs",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqajs",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY 
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtswr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlwr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : deja en K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtec",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvvdf",itau_w,zx_tmp_fi3d)
+c
+      IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoro",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoro",itau_w,zx_tmp_fi3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dulif",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvlif",itau_w,zx_tmp_fi3d)
+      ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      CALL histwrite_phy(nid_mth,"tau",itau_w,cldtau)
+      CALL histwrite_phy(nid_mth,"CCM1",itau_w,ccm(:,:,1))
+      CALL histwrite_phy(nid_mth,"CCM2",itau_w,ccm(:,:,2))
+      CALL histwrite_phy(nid_mth,"taupi",itau_w,cldtaupi)
+      CALL histwrite_phy(nid_mth,"cldemi",itau_w,cldemi)
+      CALL histwrite_phy(nid_mth,"SWTOAAS_ZERO",itau_w,topsw_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AER",itau_w,topsw_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_NAT",itau_w,topsw_inca(:,3))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AD",itau_w,topswad_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AI",itau_w,topswai_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_ZERO",itau_w,topsw0_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AER",itau_w,topsw0_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AD",itau_w,topswad0_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_NAT",itau_w,topsw0_inca(:,3))
+#endif
+#ifndef INCA
+      IF (nqmax.GE.3) THEN
+      DO iq=3,nqmax
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq), zx_tmp_3d)
+         CALL histwrite_phy(nid_mth,tnom(iq),itau_w,qx(:,:,iq))
+      ENDDO
+      ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+c Champs 2D:
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis/RG,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phis",itau_w,pphis/RG)
+C
+cIM 310804   CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"aire",itau_w,airephy)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_ter),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_ter),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_lic)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_lic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_lic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_sic)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_sic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_sic),itau_w,
+     $      zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"flat",itau_w,zxfluxlat)
+c
+      zx_tmp_fi2d(1 : klon) = topsw(1:klon)-toplw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bilTOA",itau_w,zx_tmp_fi2d)
+c
+c     IF(itap.EQ.ecrit_mth) THEN
+c       DO i=1, klon
+c         IF(nday_clr(i).GT.0.) THEN
+c          tops01(i)=tops01(i)/nday_clr(i)
+c         ELSE
+c          tops01(i)=1.e+20
+c         ENDIF
+c       ENDDO
+c       CALL gr_fi_ecrit(1, klon,iim,jjmp1, tops01,zx_tmp_2d)
+c       CALL histwrite_phy(nid_mth,"tops01",itau_w,zx_tmp_2d,
+c    .       iim*jjmp1,ndex2d)
+c     ENDIF !itap.EQ.ecrit_mth 
+c
+c220404 BEG
+c
+c temperature tendency due to total diabatic heating
+       DO l=1, klev
+       DO i=1, klon
+       d_t(i,l) = (t_seri(i,l)-t(i,l))/dtime
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdia",itau_w,d_t)
+c
+c temperature tendency due to SW radiation
+       DO l=1, klev
+       DO i=1, klon
+       zx_tmp_fi3d(i,l)=heat(i,l)/RDAY
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw",itau_w,zx_tmp_fi3d)
+c
+c temperature tendency due to LW radiation
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=-1*cool(i,l)/RDAY
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw",itau_w,zx_tmp_fi3d)
+c
+c  temperature tendency due to moist convective processes
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=d_t_con(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtcon",itau_w,zx_tmp_fi3d)
+c
+c temperature tendency due to dry convective processes
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=d_t_ajs(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtajs",itau_w,zx_tmp_fi3d)
+c
+c  temperature tendency due to large scale precipitation
+       DO l=1, klev
+       DO i=1, klon
+       zx_tmp_fi3d(i,l)=d_t_lsc(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlsc",itau_w,zx_tmp_fi3d)
+c
+c  total moisture tendency due to diabatic processes
+       DO l=1, klev
+       DO i=1, klon
+        d_qx(i,l,ivap) = ( q_seri(i,l) - qx(i,l,ivap) ) / dtime
+        zx_tmp_fi3d(i,l)=d_qx(i,l,ivap)
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdia",itau_w,zx_tmp_fi3d)
+c
+cBEG 210404 BEG
+c
+      IF(ok_orodr.AND.ok_orolf) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = (d_u_oro(i,k) + d_u_lif(i,k))/pdtphys
+        d_v_oli(i,k) = (d_v_oro(i,k) + d_v_lif(i,k))/pdtphys
+      ENDDO
+      ENDDO
+      ENDIF !(ok_orodr.AND.ok_orolf) THEN
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_u_oli,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoli",itau_w,d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_v_oli,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoli",itau_w,d_v_oli)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ducon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvcon",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_u,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dutot",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_v,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvtot",itau_w,d_v)
+
+cEND 210404 END
+c
+c cldtrue
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldtrue,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldtrue",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldTOA,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldTOA",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldSFC,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldSFC",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+      DO i=1, klon
+cIM 151004    zx_tmp_fi2d(i)=GWDtaux1(i,1)-GWDtaux0(i,1)
+       zx_tmp_fi2d(i)=zustrdr(i)+zustrli(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"GWDtaux",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+cIM 151004    zx_tmp_fi2d(i)=GWDtauy1(i,1)-GWDtauy0(i,1)
+       zx_tmp_fi2d(i)=zvstrdr(i)+zvstrli(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"GWDtauy",itau_w,zx_tmp_fi2d)
+c
+c220404 END
+cAMIP2 END
+c
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m",itau_w,zt2m)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_min",itau_w,zt2m)
+c
+cym     CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_max",itau_w,zt2m)
+c
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"tsoil",itau_w,zx_tmp_2d,
+c    .               iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sicf",itau_w,zx_tmp_fi2d)
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"temp",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+c ENSEMBLES END
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"v10m",itau_w,zv10m)
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"psol",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"qsurf",itau_w,zxqsurf)
+c
+      if (.not. ok_veget) then
+cym          CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d)
+          CALL histwrite_phy(nid_mth,"qsol",itau_w,qsol)
+      endif
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ndayrain",itau_w,nday_rain)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"snowf",itau_w,snow_fall)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl0",itau_w,toplw0)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+c
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200",itau_w,SWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200clr",itau_w,SWup200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200",itau_w,SWdn200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200clr",itau_w,SWdn200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200",itau_w,LWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200clr",itau_w,LWup200clr)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200clr",itau_w,zx_tmp_fi2d)
+c
+c200 END 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll0",itau_w,sollw0)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       sollwdownclr(i)=-1.*lwdn0(i,1)
+      ENDDO !i=1, klon
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)-sollwdownclr(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFC",itau_w,sollwdown)
+c
+c     DO i=1, klon
+cIM 08004    sollwdownclr(i)=lwdn0(i,1)
+c      sollwdownclr(i)=-1.*lwdn0(i,1)
+c     ENDDO !i=1, klon
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFCclr",itau_w,sollwdownclr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fder",itau_w,fder)
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite_phy(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite_phy(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"ffonte",itau_w,zxffonte)
+c
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqcalving",itau_w,zxfqcalving)
+c
+       DO nsrf = 1, nbsrf
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDDO
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_oce)*100.
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_oce),itau_w,
+     $      zx_tmp_fi2d) 
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_oce)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_oce),itau_w,
+     $      zx_tmp_fi2d) 
+c
+      DO nsrf = 1, nbsrf
+CYYY
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       IF(1.EQ.0) THEN
+C
+        zx_tmp_fi2d(1:klon) = fevap(1:klon,nsrf)*pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"evapour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1:klon) = (rain_fall(1:klon) + snow_fall(1:klon))
+     $                        *pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"prepour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       ENDIF !(1.EQ.0) THEN
+C
+      END DO  
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt*100.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldt",itau_w,cldt*100.)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldq",itau_w,cldq)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ue",itau_w,ue)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ve",itau_w,ve)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"uq",itau_w,uq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"vq",itau_w,vq)
+cKE43
+      IF (iflag_con.GE.3) THEN ! sb
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cape",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pbase",itau_w,pbase)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ptop",itau_w,ema_pct)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fbase",itau_w,ema_cbmf)
+c
+c34EK
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"prw",itau_w,prw)
+c
+      ENDIF !iflag_con.GE.3
+c
+cIM cf. AM 081204 BEG
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c  Champs interpolles sur des niveaux de pression
+c     DO k=1, nlevENS
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+       IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"u"//bb2,itau_w,usumSTD(:,k,2))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"v"//bb2,itau_w,vsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"w"//bb2,itau_w,wsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phi"//bb2,itau_w,phisumSTD(:,k,2))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700"
+      ENDDO !nlevSTD
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     .     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ 
+     .                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     .                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t_oce_sic",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lmt_bils",itau_w,
+     .     zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slab_bils",itau_w,
+     .     zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"siceh",itau_w,seaice/1000.)
+c
+      ENDIF !OCEAN.EQ.force/slab
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+C
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"iwcon",itau_w,fiwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"temp",itau_w,t_seri)
+c
+c#ifdef histmthNMC
+c#include "write_histmthNMC.h"
+c#endif
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ovap",itau_w, qx(:,:,ivap))
+c
+c     zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/
+c    .                         (1-qx(1:klon,1:klev,ivap))
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"wvap",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra*100., zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rneb",itau_w,cldfra*100.)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rhum",itau_w,zx_rh)
+c
+      DO k=1, klev
+       DO i=1, klon
+cIM 151004        zx_tmp_fi3d(i,k)=MAX(wo(i,k),1.0e-12)*RG/46.6968
+c    $                    /(paprs(i,k)-paprs(i,k+1))
+c    $                    *(paprs(i,1)/101325.0)
+c        zx_tmp2_fi3d(i,k)=MAX(wo(i,k)*1.0e+6,1.0e-6)*RG/46.6968
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp2_fi3d,zx_tmp_3d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ozone",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap),zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqphy",itau_w,d_qx(:,:,ivap))
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+       DO nsrf=1, nbsrf
+c
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ages_"//clnsurf(nsrf),itau_w
+     $    ,agesno)
+c
+      ENDDO !nsrf=1, nbsrf
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albs",itau_w,albsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albslw",itau_w,albsollw)
+c
+      ENDIF !lev_histmth.GE.3
+c
+c
+      IF(lev_histmth.GE.4) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"clwcon",itau_w,clwcon0)
+c
+      IF (iflag_con.GE.3) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"Ma",itau_w,Ma)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"upwd",itau_w,upwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd",itau_w,dnwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd0",itau_w,dnwd0)
+c
+      ENDIF !iflag_con.GE.3
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdyn",itau_w,d_q_dyn)
+c
+cIM: 101003 : K/30min ==> K/s
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqcon",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     .                             d_t_eva(1:klon,1:klev))/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlschr",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqlsc",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqvdf",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dteva",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqeva",itau_w,zx_tmp_fi3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ptconv",itau_w,zpt_conv)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ratqs",itau_w,ratqs)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqajs",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY 
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtswr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlwr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : deja en K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtec",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvvdf",itau_w,zx_tmp_fi3d)
+c
+      IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoro",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoro",itau_w,zx_tmp_fi3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dulif",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvlif",itau_w,zx_tmp_fi3d)
+      ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      CALL histwrite_phy(nid_mth,"tau",itau_w,cldtau)
+      CALL histwrite_phy(nid_mth,"CCM1",itau_w,ccm(:,:,1))
+      CALL histwrite_phy(nid_mth,"CCM2",itau_w,ccm(:,:,2))
+      CALL histwrite_phy(nid_mth,"taupi",itau_w,cldtaupi)
+      CALL histwrite_phy(nid_mth,"cldemi",itau_w,cldemi)
+      CALL histwrite_phy(nid_mth,"SWTOAAS_ZERO",itau_w,topsw_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AER",itau_w,topsw_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_NAT",itau_w,topsw_inca(:,3))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AD",itau_w,topswad_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AI",itau_w,topswai_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_ZERO",itau_w,topsw0_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AER",itau_w,topsw0_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AD",itau_w,topswad0_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_NAT",itau_w,topsw0_inca(:,3))
+#endif
+#ifndef INCA
+      IF (nqmax.GE.3) THEN
+      DO iq=3,nqmax
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq), zx_tmp_3d)
+         CALL histwrite_phy(nid_mth,tnom(iq),itau_w,qx(:,:,iq))
+      ENDDO
+      ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ENDIF !(type_run.EQ."AMIP")
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_mth)
+c$OMP END MASTER
+      endif
+c
+      ENDIF !ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histmthNMC.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histmthNMC.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histmthNMC.h	(revision 984)
@@ -0,0 +1,126 @@
+!
+! $Header$
+!
+      IF (ok_mensuel) THEN
+c
+       ndex3d = 0
+       itau_w = itau_phy + itap
+ccc
+c  Champs interpolles sur des niveaux de pression du NMC
+c
+c     PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+ccc
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+ccc
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,2),
+cym     $      zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,2))
+ccc
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+ccc
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"w",itau_w,wsumSTD(:,:,3))
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,3).NE.1.E+20) THEN
+          zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,3))/ecrit_hf2mth
+         ELSE
+          zx_tmp_fiNC(i,k) = 1.E+20
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,zx_tmp_fiNC,zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"psbg",itau_w,zx_tmp_fiNC)
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,uvsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"uv",itau_w,uvsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vqsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vq",itau_w,vqsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vTsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vT",itau_w,vTsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1, wqsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"wq",itau_w,wqsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vphisumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vphi",itau_w,vphisumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wTsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"wT",itau_w,wTsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,u2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"uxu",itau_w,u2sumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,v2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vxv",itau_w,v2sumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,T2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"TxT",itau_w,T2sumSTD(:,:,3))
+c
+      ENDIF !type_run
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_nmc)
+c$OMP END MASTER
+      endif
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_histrac.h	(revision 984)
@@ -0,0 +1,106 @@
+!
+! $Header$
+!
+#ifndef INCA
+      ndex = 0
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + nstep
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_tra,"phis",itau_w,pphis)
+C
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,airephy,zx_tmp_2d)      
+      CALL histwrite_phy(nid_tra,"aire",itau_w,airephy)
+
+      DO it=1,nqmax
+C champs 2D
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,tr_seri(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,tnom(it+2),itau_w,tr_seri(:,:,it))
+       if (lessivage) THEN
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"fl"//tnom(it+2),itau_w,
+     .                                   flestottr(:,:,it))
+      endif
+      
+c----Olivia
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_th(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_th_"//tnom(it+2),itau_w,
+     .                                           d_tr_th(:,:,it))
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cv(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_cv_"//tnom(it+2),itau_w,
+     .                                           d_tr_cv(:,:,it))
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cl(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_cl_"//tnom(it+2),itau_w,
+     .                                           d_tr_cl(:,:,it))
+c---fin Olivia      
+      
+      ENDDO
+
+
+C abder
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,yu1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"pyu1",itau_w,yu1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,yv1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"pyv1",itau_w,yv1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol1",itau_w,pftsol1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol2,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol2",itau_w,pftsol2)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol3,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol3",itau_w,pftsol3)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol4,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol4",itau_w,pftsol4)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf1",itau_w,ppsrf1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf2,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf2",itau_w,ppsrf2)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf3,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf3",itau_w,ppsrf3)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf4,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf4",itau_w,ppsrf4)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pplay,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"pplay",itau_w,pplay)
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,t_seri,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"t",itau_w,t_seri)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfu,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"mfu",itau_w,pmfu)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfd,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"mfd",itau_w,pmfd)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_u,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"en_u",itau_w,pen_u)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_d,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"en_d",itau_w,pen_d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_d,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"de_d",itau_w,pde_d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_u,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"de_u",itau_w,pde_u)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,coefh,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"coefh",itau_w,coefh)
+
+
+c abder
+
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_tra)
+c$OMP END MASTER
+       endif
+
+#endif
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_paramLMDZ_phy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_paramLMDZ_phy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/write_paramLMDZ_phy.h	(revision 984)
@@ -0,0 +1,366 @@
+c
+      IF (is_sequential) THEN
+      
+      ndex2d = 0
+      itau_w = itau_phy + itap
+c
+c Variables type caractere : plusieurs valeurs possibles
+c
+      IF(ocean.EQ.'force ') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE IF(ocean.EQ.'slab  ') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=2.
+      ELSE IF(ocean.EQ.'couple') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=3.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ocean",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_slab_sicOBS) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_slab_sicOBS",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(type_run.EQ.'CLIM'.OR.type_run.EQ.'ENSP') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE IF(type_run.EQ.'AMIP'.OR.type_run.EQ.'CFMI') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=2.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"type_run",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c Variables logiques (1=true, 2=false)
+c
+      IF(ok_veget) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_veget",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_journe) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_journe",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_mensuel) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_mensuel",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_instan) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_instan",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_ade) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_ade",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_aie) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_aie",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+
+c
+c Champs 2D:
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=bl95_b0
+      CALL histwrite(nid_ctesGCM,"bl95_b0",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=bl95_b1
+      CALL histwrite(nid_ctesGCM,"bl95_b1",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ip_ebil_phy
+      CALL histwrite(nid_ctesGCM,"ip_ebil_phy",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_ecc
+      CALL histwrite(nid_ctesGCM,"R_ecc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_peri
+      CALL histwrite(nid_ctesGCM,"R_peri",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_incl
+      CALL histwrite(nid_ctesGCM,"R_incl",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=solaire
+      CALL histwrite(nid_ctesGCM,"solaire",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=co2_ppm
+      CALL histwrite(nid_ctesGCM,"co2_ppm",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CH4_ppb
+      CALL histwrite(nid_ctesGCM,"CH4_ppb",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=N2O_ppb
+      CALL histwrite(nid_ctesGCM,"N2O_ppb",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CFC11_ppt
+      CALL histwrite(nid_ctesGCM,"CFC11_ppt",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CFC12_ppt
+      CALL histwrite(nid_ctesGCM,"CFC12_ppt",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=epmax
+      CALL histwrite(nid_ctesGCM,"epmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Mais est-il bien raisonable de stoker ces fichiers comme des
+! champs 2D...
+! WARNING :
+! Il faudrait ici ajoute l'ecriture des champs
+!      cycle_diurne = cycle_diurne_omp
+!   soil_model = soil_model_omp
+!   new_oliq = new_oliq_omp
+!   ok_orodr = ok_orodr_omp
+!   ok_orolf = ok_orolf_omp
+!   ok_limitvrai = ok_limitvrai_omp
+!   nbapp_rad = nbapp_rad_omp
+!   iflag_con = iflag_con_omp
+! qui se trouvaient auparavant dans gcm.def et maintenant dans 
+! physiq.def.
+! Mais regarder d'abord a quoi ca sert ...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+c
+      IF(ok_adj_ema) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_adj_ema",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_clw
+      CALL histwrite(nid_ctesGCM,"iflag_clw",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_lsc
+      CALL histwrite(nid_ctesGCM,"cld_lc_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_con
+      CALL histwrite(nid_ctesGCM,"cld_lc_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_lsc
+      CALL histwrite(nid_ctesGCM,"cld_tau_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_con
+      CALL histwrite(nid_ctesGCM,"cld_tau_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ffallv_lsc
+      CALL histwrite(nid_ctesGCM,"ffallv_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ffallv_con
+      CALL histwrite(nid_ctesGCM,"ffallv_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=coef_eva
+      CALL histwrite(nid_ctesGCM,"coef_eva",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(reevap_ice) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"reevap_ice",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_cldcon
+      CALL histwrite(nid_ctesGCM,"iflag_cldcon",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_pdf
+      CALL histwrite(nid_ctesGCM,"iflag_pdf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=fact_cldcon
+      CALL histwrite(nid_ctesGCM,"fact_cldcon",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=facttemps
+      CALL histwrite(nid_ctesGCM,"facttemps",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_newmicro) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_newmicro",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ratqsbas
+      CALL histwrite(nid_ctesGCM,"ratqsbas",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ratqshaut
+      CALL histwrite(nid_ctesGCM,"ratqshaut",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_froid
+      CALL histwrite(nid_ctesGCM,"rad_froid",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_chau1
+      CALL histwrite(nid_ctesGCM,"rad_chau1",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_chau2
+      CALL histwrite(nid_ctesGCM,"rad_chau2",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=top_height
+      CALL histwrite(nid_ctesGCM,"top_height",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=overlap
+      CALL histwrite(nid_ctesGCM,"overlap",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cdmmax
+      CALL histwrite(nid_ctesGCM,"cdmmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cdhmax
+      CALL histwrite(nid_ctesGCM,"cdhmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ksta
+      CALL histwrite(nid_ctesGCM,"ksta",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ksta_ter
+      CALL histwrite(nid_ctesGCM,"ksta_ter",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_kzmin) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_kzmin",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_pbl
+      CALL histwrite(nid_ctesGCM,"iflag_pbl",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histhf
+      CALL histwrite(nid_ctesGCM,"lev_histhf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histday
+      CALL histwrite(nid_ctesGCM,"lev_histday",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histmth
+      CALL histwrite(nid_ctesGCM,"lev_histmth",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_isccp) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_isccp",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lonmin_ins
+      CALL histwrite(nid_ctesGCM,"lonmin_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lonmax_ins
+      CALL histwrite(nid_ctesGCM,"lonmax_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=latmin_ins
+      CALL histwrite(nid_ctesGCM,"latmin_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=latmax_ins
+      CALL histwrite(nid_ctesGCM,"latmax_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ins
+      CALL histwrite(nid_ctesGCM,"ecrit_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_hf
+      CALL histwrite(nid_ctesGCM,"ecrit_hf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_day
+      CALL histwrite(nid_ctesGCM,"ecrit_day",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_mth
+      CALL histwrite(nid_ctesGCM,"ecrit_mth",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_tra
+      CALL histwrite(nid_ctesGCM,"ecrit_tra",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_reg
+      CALL histwrite(nid_ctesGCM,"ecrit_reg",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=freq_ISCCP
+      CALL histwrite(nid_ctesGCM,"freq_ISCCP",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ISCCP
+      CALL histwrite(nid_ctesGCM,"ecrit_ISCCP",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_ctesGCM)
+      endif
+c
+      ENDIF ! mono_cpu
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/yamada.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/yamada.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/yamada.F	(revision 984)
@@ -0,0 +1,173 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer l_mix,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      save first
+      data first/.true./
+
+
+      integer ig,k
+
+      real ri,zrif,zalpha,zsm
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real l(klon,klev+1),l0(klon)
+
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/
+
+      real frif,falpha,fsm
+
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+         print*,ri,rif,zalpha,zsm
+      enddo
+      first=.false.
+      endif
+
+c  Correction d'un bug sauvage a verifier.
+c      do k=2,nlev
+      do k=2,nlay
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1))
+     s            /(teta(ig,k-1)+teta(ig,k))  /dz(ig,k)
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+c iterration pour determiner la longueur de melange
+
+                                                          do ig=1,ngrid
+      l0(ig)=100.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+c(abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+                                                          enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/yamada4.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/yamada4.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/yamada4.F	(revision 984)
@@ -0,0 +1,480 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar
+     s   ,iflag_pbl)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c  iflag_pbl doit valoir entre 6 et 9
+c      l=6, on prend  systematiquement une longueur d'equilibre
+c    iflag_pbl=6 : MY 2.0
+c    iflag_pbl=7 : MY 2.0.Fournier
+c    iflag_pbl=8 : MY 2.5
+c    iflag_pbl=9 : un test ?
+
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),qpre
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+
+      REAL km(klon,klev+1)
+      REAL kmpre(klon,klev+1),tmp2
+      REAL mpre(klon,klev+1)
+      REAL kn(klon,klev+1)
+      REAL kq(klon,klev+1)
+      real ff(klon,klev+1),delta(klon,klev+1)
+      real aa(klon,klev+1),aa0,aa1
+      integer iflag_pbl,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      integer ipas
+      save first,ipas
+      data first,ipas/.true.,0/
+c$OMP THREADPRIVATE( first,ipas)
+
+      integer ig,k
+
+
+      real ri,zrif,zalpha,zsm,zsn
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real dtetadz(klon,klev+1)
+      real m2cstat,mcstat,kmcstat
+      real l(klon,klev+1)
+      real,allocatable,save :: l0(:)
+c$OMP THREADPRIVATE(l0)      
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
+c$OMP THREADPRIVATE(ric,rifc,b1,kap)
+      real frif,falpha,fsm
+      real fl,zzz,zl0,zq2,zn2
+
+cym      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
+cym     s  ,lyam(klon,klev),knyam(klon,klev)
+cym     s  ,w2yam(klon,klev),t2yam(klon,klev)
+      real,allocatable,save,dimension(:,:) :: rino,smyam,styam,lyam,
+     s                                        knyam,w2yam,t2yam
+cym      common/pbldiag/rino,smyam,styam,lyam,knyam,w2yam,t2yam
+c$OMP THREADPRIVATE(rino,smyam,styam,lyam,knyam,w2yam,t2yam)
+      logical,save :: firstcall=.true.
+c$OMP THREADPRIVATE(firstcall)       
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+      fl(zzz,zl0,zq2,zn2)=
+     s     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
+
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (firstcall) then
+        allocate(rino(klon,klev+1),smyam(klon,klev),styam(klon,klev))
+        allocate(lyam(klon,klev),knyam(klon,klev))
+        allocate(w2yam(klon,klev),t2yam(klon,klev))
+	allocate(l0(klon))
+	firstcall=.false.
+      endif
+
+
+      if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.9)) then
+           stop'probleme de coherence dans appel a MY'
+      endif
+
+      ipas=ipas+1
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+c     print*,ri,rif,zalpha,zsm
+      enddo
+      endif
+
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO ig=1,ngrid
+            zlev(ig,nlev)=zlay(ig,nlay)
+     &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
+                                                      ENDDO
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO k=1,nlay
+                                                      DO ig=1,ngrid
+        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+                                                      ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
+                                                      ENDDO
+      DO k=2,nlay
+                                                      DO ig=1,ngrid
+        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+                                                     ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+                                                     ENDDO
+c
+c.......................................................................
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
+         n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
+c        n2(ig,k)=0.
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+c     print*,'RIF L=',k,rif(ig,k),ri*alpha(ig,k)
+
+
+                                                          enddo
+      enddo
+
+
+c====================================================================
+c   Au premier appel, on determine l et q2 de facon iterative.
+c iterration pour determiner la longueur de melange
+
+
+      if (first.or.iflag_pbl.eq.6) then
+                                                          do ig=1,ngrid
+      l0(ig)=10.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+c        l0(ig)=30.
+                                                          enddo
+c      print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+c     print*,'Fin de l initialisation de q2 et l0'
+
+      endif ! first
+
+c====================================================================
+c  Calcul de la longueur de melange.
+c====================================================================
+
+c   Mise a jour de l0
+                                                          do ig=1,ngrid
+      sq(ig)=1.e-10
+      sqz(ig)=1.e-10
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        zq=sqrt(q2(ig,k))
+        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+      enddo
+                                                          do ig=1,ngrid
+      l0(ig)=0.2*sqz(ig)/sq(ig)
+c        l0(ig)=30.
+                                                          enddo
+c      print*,'ITER=',iter,'  L0=',l0
+c   calcul de l(z)
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+         if(first) then
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         endif
+                                                          enddo
+      enddo
+
+c====================================================================
+c   Yamada 2.0
+c====================================================================
+      if (iflag_pbl.eq.6) then
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+                                                          enddo
+      enddo
+
+
+      else if (iflag_pbl.eq.7) then
+c====================================================================
+c   Yamada 2.Fournier
+c====================================================================
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         mpre(ig,k)=sqrt(m2(ig,k))
+c        print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+                                                          enddo
+      enddo
+
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12)
+        mcstat=sqrt(m2cstat)
+
+c        print*,'M2 L=',k,mpre(ig,k),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (k.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)
+     &              *cd(ig)
+     &              *( sqrt(u(ig,3)**2+v(ig,3)**2)
+     &                -mcstat/unsdzdec(ig,k)
+     &                -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2)
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)*kmpre(ig,k-1)
+     &                          *mpre(ig,k-1) )
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ENDIF
+c       print*,'T2 L=',k,tmp2
+        tmp2=kmcstat
+     &      /( sm(ig,k)/q2(ig,k) )
+     &      /l(ig,k)
+        q2(ig,k)=max(tmp2,1.e-12)**(2./3.)
+c       print*,'Q2 L=',k,q2(ig,k)
+c
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl.ge.8) then
+c====================================================================
+c   Yamada 2.5 a la Didi
+c====================================================================
+
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         if (delta(ig,k).lt.1.e-20) then
+c     print*,'ATTENTION   L=',k,'   Delta=',delta(ig,k)
+            delta(ig,k)=1.e-20
+         endif
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         aa0=
+     s   (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+         aa1=
+     s   (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+c abder      print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20)
+         aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k))
+c     print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+         qpre=sqrt(q2(ig,k))
+         if (iflag_pbl.eq.8 ) then
+            if (aa(ig,k).gt.0.) then
+               q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+         else ! iflag_pbl=9
+            if (aa(ig,k)*qpre.gt.0.9) then
+               q2(ig,k)=(qpre*10.)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+         endif
+         q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4)
+c     print*,'Q2 L=',k,q2(ig,k),qpre*qpre
+                                                          enddo
+      enddo
+
+      endif ! Fin du cas 8
+
+c     print*,'OK8'
+
+c====================================================================
+c   Calcul des coefficients de m�ange
+c====================================================================
+      do k=2,klev
+c     print*,'k=',k
+                                                          do ig=1,ngrid
+cabde      print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k)
+         zq=sqrt(q2(ig,k))
+         km(ig,k)=l(ig,k)*zq*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+         kq(ig,k)=l(ig,k)*zq*0.2
+c     print*,'KML=',km(ig,k),kn(ig,k)
+                                                          enddo
+      enddo
+
+c     if (iflag_pbl.ge.7..and.0.eq.1) then
+c        q2(:,1)=q2(:,2)
+c        call vdif_q2(dt,g,rconst,plev,temp,kq,q2)
+c     endif
+
+c   Traitement des cas noctrunes avec l'introduction d'une longueur
+c   minilale.
+
+c====================================================================
+c   Traitement particulier pour les cas tres stables.
+c   D'apres Holtslag Boville.
+
+      print*,'YAMADA4 0'
+
+                                                          do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+                                                          enddo
+
+       print*,'pblhmin ',pblhmin
+CTest a remettre 21 11 02
+c test abd 13 05 02      if(0.eq.1) then
+      if(1.eq.1) then
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+c   la longueur de melange est suposee etre l= kap z
+c   K=l q Sm d'ou q2=(K/l Sm)**2
+               q2(ig,k)=(qmin/sm(ig,k))**2
+            endif
+         enddo
+      enddo
+      endif
+
+      print*,'YAMADA4 1'
+c   Diagnostique pour stokage
+
+      rino=rif
+      smyam(:,1:klev)=sm(:,1:klev)
+      styam=sm(:,1:klev)*alpha(:,1:klev)
+      lyam(1:klon,1:klev)=l(:,1:klev)
+      knyam(1:klon,1:klev)=kn(:,1:klev)
+
+c   Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+
+        if(1.eq.0)then
+      w2yam=q2(:,1:klev)*0.24
+     s    +lyam(:,1:klev)*5.17*kn(:,1:klev)*n2(:,1:klev)
+     s   /sqrt(q2(:,1:klev))
+
+      t2yam=9.1*kn(:,1:klev)*dtetadz(:,1:klev)**2/sqrt(q2(:,1:klev))
+     s  *lyam(:,1:klev)
+	endif
+
+c     print*,'OKFIN'
+      first=.false.
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/zilch.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/zilch.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phy_IPCC_AR4/zilch.F	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      subroutine zilch(x,m)
+c
+c Zero the real array x dimensioned m.
+c
+      implicit none
+c
+      integer m,i
+      real x(m)
+      do 1 i=1,m
+      x(i)= 0.0  
+    1 continue
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/FCTTRE.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/FCTTRE.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/FCTTRE.h	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!     ------------------------------------------------------------------
+!     This COMDECK includes the Thermodynamical functions for the cy39
+!       ECMWF Physics package.
+!       Consistent with YOMCST Basic physics constants, assuming the
+!       partial pressure of water vapour is given by a first order
+!       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
+!       in YOETHF
+!     ------------------------------------------------------------------
+      REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
+      REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
+      LOGICAL thermcep
+      PARAMETER (thermcep=.TRUE.)
+!
+      FOEEW ( PTARG,PDELARG ) = EXP (                                   &
+     &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)        &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+!
+      FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
+!
+      qsats(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (2.07023 - 0.00320991 * ptarg                       &
+     &           - 2484.896 / ptarg + 3.56654 * LOG10(ptarg))
+      qsatl(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (23.8319 - 2948.964 / ptarg                         &
+     &           - 5.028 * LOG10(ptarg)                                 &
+     &           - 29810.16 * EXP( - 0.0699382 * ptarg)                 &
+     &           + 25.21935 * EXP( - 2999.924 / ptarg))
+!
+      dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg         &
+     &                     +2484.896*LOG(10.)/ptarg**2                  &
+     &                     -0.00320991*LOG(10.))
+      dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)*                &
+     &                (2948.964/ptarg**2-5.028/LOG(10.)/ptarg           &
+     &                +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg)  &
+     &                +29810.16*0.0699382*EXP(-0.0699382*ptarg))
Index: LMDZ4/tags/LF_20080728/libf/phylmd/YOECUMF.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/YOECUMF.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/YOECUMF.h	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+C     ----------------------------------------------------------------
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C     ----------------------------------------------------------------
+C
+      COMMON /YOECUMF/
+     L                 LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV,
+     R                 ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,
+     R                 CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON
+C
+      LOGICAL          LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
+      REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
+      REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
+c$OMP THREADPRIVATE(/YOECUMF/)
+C
+*if (DOC,declared) <> 'UNKNOWN'
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C
+C     M.TIEDTKE       E. C. M. W. F.      18/1/89
+C
+C     NAME      TYPE      PURPOSE
+C     ----      ----      -------
+C
+C     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
+C     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
+C     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
+C     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
+C     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
+C     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+C     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
+C     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+C     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+C     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
+C     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
+C     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
+C     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+C     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
+C     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
+C                        FROM CLOUD WATER TO RAIN
+*ifend
+C     ----------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phylmd/YOEGWD.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/YOEGWD.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/YOEGWD.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+C     -----------------------------------------------------------------
+C*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+C     -----------------------------------------------------------------
+C
+      integer NKTOPG,NSTRA
+      real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+      real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC
+      COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+     *        ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC
+c$OMP THREADPRIVATE(/YOEGWD/)
+C
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/YOETHF.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/YOETHF.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/YOETHF.h	(revision 984)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
+!
+!     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
+!                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
+!                ICE(*R_IES*).
+!     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
+!     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
+!
+      REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
+      REAL RVTMP2, RHOH2O
+      COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES,    &
+     &               RVTMP2, RHOH2O
+!$OMP THREADPRIVATE(/YOETHF/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/YOMCST.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/YOMCST.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/YOMCST.h	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! A1.0 Fundamental constants
+      REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO
+! A1.1 Astronomical constants
+      REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
+! A1.1.bis Constantes concernant l'orbite de la Terre:
+      REAL R_ecc, R_peri, R_incl
+! A1.2 Geoide
+      REAL RA,RG,R1SA
+! A1.3 Radiation
+!     REAL RSIGMA,RI0
+      REAL RSIGMA
+! A1.4 Thermodynamic gas phase
+      REAL R,RMD,RMO3,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
+      REAL RKAPPA,RETV
+! A1.5,6 Thermodynamic liquid,solid phases
+      REAL RCW,RCS
+! A1.7 Thermodynamic transition of phase
+      REAL RLVTT,RLSTT,RLMLT,RTT,RATM
+! A1.8 Curve of saturation
+      REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
+      REAL RALPD,RBETD,RGAMD
+!
+      COMMON/YOMCST/RPI   ,RCLUM ,RHPLA ,RKBOL ,RNAVO                   &
+     &      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA                  &
+     &      ,R_ecc, R_peri, R_incl                                      &
+     &      ,RA    ,RG    ,R1SA                                         &
+     &      ,RSIGMA                                                     &
+     &      ,R     ,RMD   ,RMO3  ,RMV   ,RD    ,RV    ,RCPD             &
+     &      ,RCPV  ,RCVD  ,RCVV  ,RKAPPA,RETV                           &
+     &      ,RCW   ,RCS                                                 &
+     &      ,RLVTT ,RLSTT ,RLMLT ,RTT   ,RATM                           &
+     &      ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS            &
+     &      ,RALPD ,RBETD ,RGAMD
+!    ------------------------------------------------------------------
+!$OMP THREADPRIVATE(/YOMCST/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/YOMCST2.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/YOMCST2.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/YOMCST2.h	(revision 984)
@@ -0,0 +1,12 @@
+
+      INTEGER choice, iflag_mix
+      REAL  gammas, alphas, betas, Fmax, qqa1, qqa2, qqa3, scut
+      REAL  Qcoef1max,Qcoef2max,Supcrit1,Supcrit2
+!
+      COMMON/YOMCST2/gammas,    alphas, betas, Fmax, scut,              &
+     &               qqa1, qqa2, qqa3,                                  &
+     &               Qcoef1max,Qcoef2max,                               &
+     &               Supcrit1, Supcrit2,                                &
+     &               choice,iflag_mix
+!    --------------------------------------------------------------------
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/aaam_bud.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/aaam_bud.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/aaam_bud.F	(revision 984)
@@ -0,0 +1,367 @@
+!
+! $Header$
+!
+      subroutine aaam_bud (iam,nlon,nlev,rjour,rsec,
+     i                   rea,rg,ome,      
+     i                   plat,plon,phis,
+     i                   dragu,liftu,phyu,
+     i                   dragv,liftv,phyv,
+     i                   p, u, v,
+     o                   aam, torsfc)
+c
+      use dimphy
+      implicit none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 20031020
+c Object: Compute different terms of the axial AAAM Budget.
+C No outputs, every AAM quantities are written on the IAM
+C File. 
+c
+c Modif : I.Musat (LMD/CNRS) date : 20041020
+c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc",
+c but no write in the iam file.
+c
+C WARNING: Only valid for regular rectangular grids.
+C REMARK: CALL DANS PHYSIQ AFTER lift_noro:
+C        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+C    C               ra,rg,romega,
+C    C               rlat,rlon,pphis,
+C    C               zustrdr,zustrli,zustrph,
+C    C               zvstrdr,zvstrli,zvstrph,
+C    C               paprs,u,v)
+C
+C======================================================================
+c Explicit Arguments:
+c ==================
+c iam-----input-I-File number where AAMs and torques are written
+c                 It is a formatted file that has been opened
+c                 in physiq.F
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c rjour---input-R-Jour compte depuis le debut de la simu (run.def)
+c rsec----input-R-Seconde de la journee
+c rea-----input-R-Earth radius
+c rg------input-R-gravity constant
+c ome-----input-R-Earth rotation rate
+c plat ---input-R-Latitude en degres
+c plon ---input-R-Longitude en degres
+c phis ---input-R-Geopotential at the ground
+c dragu---input-R-orodrag stress (zonal)
+c liftu---input-R-orolift stress (zonal)
+c phyu----input-R-Stress total de la physique (zonal)
+c dragv---input-R-orodrag stress (Meridional)
+c liftv---input-R-orolift stress (Meridional)
+c phyv----input-R-Stress total de la physique (Meridional)
+c p-------input-R-Pressure (Pa) at model half levels
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c aam-----output-R-Axial Wind AAM (=raam(3))
+c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                iim*(jjm-1)+2 for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c dlat-----R: Latitude increment (Radians)
+c dlon-----R: Longitude increment (Radians)
+c raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c tmou-----R: Resolved Mountain torque (3 components)
+c tsso-----R: Parameterised Moutain drag torque (3 components)
+c tbls-----R: Parameterised Boundary layer torque (3 components)
+c
+c LOCAL ARRAY:
+c ===========
+c zs    ---R: Topographic height
+c ps    ---R: Surface Pressure  
+c ub    ---R: Barotropic wind zonal
+c vb    ---R: Barotropic wind meridional
+c zlat  ---R: Latitude in radians
+c zlon  ---R: Longitude in radians
+c======================================================================
+
+#include "dimensions.h"
+ccc#include "dimphy.h"
+c
+c ARGUMENTS
+c
+      INTEGER iam,nlon,nlev
+      REAL rjour,rsec,rea,rg,ome
+      REAL plat(nlon),plon(nlon),phis(nlon)
+      REAL dragu(nlon),liftu(nlon),phyu(nlon)             
+      REAL dragv(nlon),liftv(nlon),phyv(nlon)             
+      REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev)
+c
+c Variables locales:
+c
+      INTEGER i,j,k,l
+      REAL xpi,hadley,hadday
+      REAL dlat,dlon
+      REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3)
+      integer iax
+cIM ajout aam, torsfc
+c aam = composante axiale du Wind AAM raam
+c torsfc = composante axiale de (tmou+tsso+tbls)
+      REAL aam, torsfc
+
+      REAL ZS(801,401),PS(801,401)
+      REAL UB(801,401),VB(801,401)
+      REAL SSOU(801,401),SSOV(801,401)
+      REAL BLSU(801,401),BLSV(801,401)
+      REAL ZLON(801),ZLAT(401)
+C
+C  PUT AAM QUANTITIES AT ZERO:
+C
+      if(iim+1.gt.801.or.jjm+1.gt.401)then
+      print *,' Pb de dimension dans aaam_bud'
+      stop
+      endif
+
+      xpi=acos(-1.)
+      hadley=1.e18
+      hadday=1.e18*24.*3600.
+      dlat=xpi/float(jjm)
+      dlon=2.*xpi/float(iim) 
+      
+      do iax=1,3
+      oaam(iax)=0.
+      raam(iax)=0.
+      tmou(iax)=0.
+      tsso(iax)=0.
+      tbls(iax)=0.
+      enddo
+
+C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
+
+C North pole values (j=1):
+ 
+      l=1
+
+        ub(1,1)=0.
+        vb(1,1)=0.
+        do k=1,nlev
+          ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+          vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+        enddo
+
+          zlat(1)=plat(l)*xpi/180.
+
+        do i=1,iim+1
+
+          zs(i,1)=phis(l)/rg
+          ps(i,1)=p(l,1)
+          ub(i,1)=ub(1,1)                             
+          vb(i,1)=vb(1,1)                             
+          ssou(i,1)=dragu(l)+liftu(l)
+          ssov(i,1)=dragv(l)+liftv(l)
+          blsu(i,1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,1)=phyv(l)-dragv(l)-liftv(l)
+
+        enddo
+
+
+      do j = 2,jjm
+
+C Values at Greenwich (Periodicity)
+
+      zs(iim+1,j)=phis(l+1)/rg
+      ps(iim+1,j)=p(l+1,1)
+          ssou(iim+1,j)=dragu(l+1)+liftu(l+1)
+          ssov(iim+1,j)=dragv(l+1)+liftv(l+1)
+          blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1)
+          blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1)
+      zlon(iim+1)=-plon(l+1)*xpi/180.
+      zlat(j)=plat(l+1)*xpi/180.
+
+      ub(iim+1,j)=0.
+      vb(iim+1,j)=0.
+         do k=1,nlev
+         ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         enddo
+      
+
+      do i=1,iim
+
+      l=l+1
+      zs(i,j)=phis(l)/rg
+      ps(i,j)=p(l,1)
+          ssou(i,j)=dragu(l)+liftu(l)
+          ssov(i,j)=dragv(l)+liftv(l)
+          blsu(i,j)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,j)=phyv(l)-dragv(l)-liftv(l)
+      zlon(i)=plon(l)*xpi/180.
+
+      ub(i,j)=0.
+      vb(i,j)=0.
+         do k=1,nlev
+         ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+         enddo
+
+      enddo
+
+      enddo
+
+
+C South Pole
+
+      if (jjm.GT.1) then
+      l=l+1
+      ub(1,jjm+1)=0.
+      vb(1,jjm+1)=0.
+      do k=1,nlev
+         ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+      enddo
+      zlat(jjm+1)=plat(l)*xpi/180.
+
+      do i=1,iim+1
+      zs(i,jjm+1)=phis(l)/rg
+      ps(i,jjm+1)=p(l,1)
+          ssou(i,jjm+1)=dragu(l)+liftu(l)
+          ssov(i,jjm+1)=dragv(l)+liftv(l)
+          blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l)
+      ub(i,jjm+1)=ub(1,jjm+1)                               
+      vb(i,jjm+1)=vb(1,jjm+1)                                
+      enddo
+      endif
+
+C
+C  MOMENT ANGULAIRE 
+C
+        DO j=1,jjm    
+        DO i=1,iim
+
+           raam(1)=raam(1)-rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +cos(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    +rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +sin(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (cos(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +cos(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(2)=raam(2)-rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +sin(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    -rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +cos(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (sin(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +sin(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(3)=raam(3)+rea**3*dlon*dlat*0.5*
+     c           (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1))
+
+           oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5*
+     c        (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1))
+
+        ENDDO
+        ENDDO
+
+C
+C COUPLE DES MONTAGNES:
+C
+
+        DO j=1,jjm
+        DO i=1,iim
+           tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+           tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+        ENDDO
+        ENDDO
+           
+        DO j=2,jjm 
+        DO i=1,iim
+           tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
+           tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
+           tmou(3)=tmou(3)-rea**2*dlat*0.5*
+     c  cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j))
+        ENDDO
+        ENDDO
+
+C
+C COUPLES DES DIFFERENTES FRICTION AU SOL:
+C
+        l=1
+        DO j=2,jjm
+        DO i=1,iim
+        l=l+1
+           tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *sin(zlon(i))
+
+           tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *cos(zlon(i))
+
+           tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *cos(zlat(j))
+
+           tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *sin(zlon(i))
+
+           tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *cos(zlon(i))
+
+           tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *cos(zlat(j))
+
+        ENDDO
+        ENDDO
+            
+
+c     write(*,*) 'AAM',rsec,
+c     write(*,*) 'AAM',rjour+rsec/86400.,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+
+c     write(iam,100)rjour+rsec/86400.,
+c    c      raam(1)/hadday,oaam(1)/hadday,
+c    c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
+c    c      raam(2)/hadday,oaam(2)/hadday,
+c    c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley 
+100   format(F12.5,15(1x,F12.5))
+
+c     write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1)
+c
+      aam=raam(3)
+      torsfc= tmou(3)+tsso(3)+tbls(3)
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/add_phys_tend.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/add_phys_tend.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/add_phys_tend.F90	(revision 984)
@@ -0,0 +1,185 @@
+!
+! $Header$
+!
+SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,text)
+!======================================================================
+! Ajoute les tendances des variables physiques aux variables 
+! d'etat de la dynamique t_seri, q_seri ...
+! On en profite pour faire des tests sur les tendances en question.
+!======================================================================
+
+
+!======================================================================
+! Declarations
+!======================================================================
+
+use dimphy
+use phys_local_var_mod
+use phys_state_var_mod
+IMPLICIT none
+#include "iniprint.h"
+
+! Arguments :
+!------------
+REAL zdu(klon,klev),zdv(klon,klev)
+REAL zdt(klon,klev),zdq(klon,klev),zdql(klon,klev)
+CHARACTER*(*) text
+
+! Local :
+!--------
+REAL zt,zq
+
+INTEGER i, k,j
+INTEGER jadrs(klon*klev), jbad
+INTEGER jqadrs(klon*klev), jqbad
+INTEGER kadrs(klon*klev)
+INTEGER kqadrs(klon*klev)
+
+integer debug_level
+logical, save :: first=.true.
+INTEGER, SAVE :: itap
+!======================================================================
+! Initialisations
+
+debug_level=10
+     if (first) then
+        itap=0
+        first=.false.
+     endif
+! Incrementer le compteur de la physique
+     itap   = itap + 1
+!======================================================================
+! Ajout des tendances sur le vent et l'eau liquide
+!======================================================================
+
+     u_seri(:,:)=u_seri(:,:)+zdu(:,:)
+     v_seri(:,:)=v_seri(:,:)+zdv(:,:)
+     ql_seri(:,:)=ql_seri(:,:)+zdql(:,:)
+
+!======================================================================
+! On ajoute les tendances de la temperature et de la vapeur d'eau
+! en verifiant que ca ne part pas dans les choux
+!======================================================================
+
+      jbad=0
+      jqbad=0
+      DO k = 1, klev
+         DO i = 1, klon
+            zt=t_seri(i,k)+zdt(i,k)
+            zq=q_seri(i,k)+zdq(i,k)
+            IF ( zt>370. .or. zt<130. .or. abs(zdt(i,k))>50. ) then
+            jbad = jbad + 1
+            jadrs(jbad) = i
+            kadrs(jbad) = k
+            ENDIF
+            IF ( zq<0. .or. zq>0.1 .or. abs(zdq(i,k))>1.e-2 ) then
+            jqbad = jqbad + 1
+            jqadrs(jqbad) = i
+            kqadrs(jqbad) = k
+            ENDIF
+            t_seri(i,k)=zt
+            q_seri(i,k)=zq
+         ENDDO
+      ENDDO
+
+!=====================================================================================
+! Impression et stop en cas de probleme important
+!=====================================================================================
+
+IF (jbad .GT. 0) THEN
+      DO j = 1, jbad
+         i=jadrs(j)
+         print*,'PLANTAGE POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
+         print*,'l    T     dT       Q     dQ    '
+         DO k = 1, klev
+             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+         ENDDO
+         call print_debug_phys(i,debug_level,text)
+      ENDDO
+ENDIF
+!
+!=====================================================================================
+! Impression, warning et correction en cas de probleme moins important
+!=====================================================================================
+IF (jqbad .GT. 0) THEN
+      DO j = 1, jqbad
+         i=jqadrs(j)
+         print*,'WARNING  : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
+         print*,'l    T     dT       Q     dQ    '
+         DO k = 1, klev
+           zq=q_seri(i,k)+zdq(i,k)
+           if (zq.lt.1.e-15) then
+              if (q_seri(i,k).lt.1.e-15) then
+!              print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k)
+               q_seri(i,k)=1.e-15
+               zdq(i,k)=(1.e-15-q_seri(i,k))
+              endif
+           endif
+!           zq=q_seri(i,k)+zdq(i,k)
+!           if (zq.lt.1.e-15) then
+!              zdq(i,k)=(1.e-15-q_seri(i,k))
+!           endif
+         ENDDO
+      ENDDO
+ENDIF
+!
+
+!IM ajout memes tests pour reverifier les jbad, jqbad beg
+      jbad=0
+      jqbad=0
+      DO k = 1, klev
+         DO i = 1, klon
+            IF ( t_seri(i,k)>370. .or. t_seri(i,k)<130. .or. abs(zdt(i,k))>50. ) then
+            jbad = jbad + 1
+            jadrs(jbad) = i
+!           if(prt_level.ge.10) THEN 
+!             print*,'cas2 i k t_seri zdt',i,k,t_seri(i,k),zdt(i,k)
+!           endif
+            ENDIF
+            IF ( q_seri(i,k)<0. .or. q_seri(i,k)>0.1 .or. abs(zdq(i,k))>1.e-2 ) then
+            jqbad = jqbad + 1
+            jqadrs(jqbad) = i
+            kqadrs(jqbad) = k
+!           if(prt_level.ge.10) THEN 
+!             print*,'cas2 i k q_seri zdq',i,k,q_seri(i,k),zdq(i,k)
+!           endif
+            ENDIF
+         ENDDO
+      ENDDO
+IF (jbad .GT. 0) THEN
+      DO j = 1, jbad
+         i=jadrs(j)
+         k=kadrs(j)
+         print*,'PLANTAGE2 POUR LE POINT i itap rlon rlat txt jbad zdt t',i,itap,rlon(i),rlat(i),text,jbad, &
+       &        zdt(i,k),t_seri(i,k)-zdt(i,k)
+!        if(prt_level.ge.10) THEN 
+         if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         endif
+      ENDDO
+ENDIF
+!
+IF (jqbad .GT. 0) THEN
+      DO j = 1, jqbad
+         i=jqadrs(j)
+         k=kqadrs(j)
+         print*,'WARNING  : EAU2 POUR LE POINT i itap rlon rlat txt jqbad zdq q zdql ql',i,itap,rlon(i),rlat(i),text,jqbad,&
+       &        zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k)
+!        if(prt_level.ge.10) THEN 
+         if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+            write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         endif
+      ENDDO
+ENDIF
+
+      CALL hgardfou(t_seri,ftsol,text)
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/aeropt.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/aeropt.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/aeropt.F	(revision 984)
@@ -0,0 +1,134 @@
+!
+! $Header$
+!
+      SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl,
+     .            tau_ae, piz_ae, cg_ae, ai        )
+c
+      USE dimphy
+      IMPLICIT none
+c
+c
+c     
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev), t_seri(klon,klev)
+      REAL msulfate(klon,klev) ! masse sulfate ug SO4/m3  [ug/m^3]
+      REAL RHcl(klon,klev)     ! humidite relative ciel clair
+      REAL tau_ae(klon,klev,2) ! epaisseur optique aerosol
+      REAL piz_ae(klon,klev,2) ! single scattering albedo aerosol
+      REAL cg_ae(klon,klev,2)  ! asymmetry parameter aerosol
+      REAL ai(klon)            ! POLDER aerosol index 
+c
+c Local
+c
+      INTEGER i, k, inu
+      INTEGER RH_num, nbre_RH
+      PARAMETER (nbre_RH=12)
+      REAL RH_tab(nbre_RH)
+      REAL RH_MAX, DELTA, rh 
+      PARAMETER (RH_MAX=95.)
+      DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+      REAL zrho, zdz
+      REAL taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
+      REAL taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
+      REAL alpha_aer_sulfate(nbre_RH,5)   !--unit m2/g SO4
+      REAL alphasulfate      
+c
+c Proprietes optiques
+c
+      REAL alpha_aer(nbre_RH,2)   !--unit m2/g SO4
+      REAL cg_aer(nbre_RH,2)
+      DATA alpha_aer/.500130E+01,  .500130E+01,  .500130E+01,  
+     .               .500130E+01,  .500130E+01,  .616710E+01,  
+     .               .826850E+01,  .107687E+02,  .136976E+02,  
+     .               .162972E+02,  .211690E+02,  .354833E+02,  
+     .               .139460E+01,  .139460E+01,  .139460E+01,  
+     .               .139460E+01,  .139460E+01,  .173910E+01,  
+     .               .244380E+01,  .332320E+01,  .440120E+01,  
+     .               .539570E+01,  .734580E+01,  .136038E+02 / 
+      DATA cg_aer/.619800E+00,  .619800E+00,  .619800E+00,  
+     .            .619800E+00,  .619800E+00,  .662700E+00,  
+     .            .682100E+00,  .698500E+00,  .712500E+00,  
+     .            .721800E+00,  .734600E+00,  .755800E+00,  
+     .            .545600E+00,  .545600E+00,  .545600E+00,  
+     .            .545600E+00,  .545600E+00,  .583700E+00,  
+     .            .607100E+00,  .627700E+00,  .645800E+00,  
+     .            .658400E+00,  .676500E+00,  .708500E+00 / 
+      DATA alpha_aer_sulfate/
+     . 4.910,4.910,4.910,4.910,6.547,7.373,
+     . 8.373,9.788,12.167,14.256,17.924,28.433,
+     . 1.453,1.453,1.453,1.453,2.003,2.321,
+     . 2.711,3.282,4.287,5.210,6.914,12.305,
+     . 4.308,4.308,4.308,4.308,5.753,6.521,
+     . 7.449,8.772,11.014,12.999,16.518,26.772,
+     . 3.265,3.265,3.265,3.265,4.388,5.016,
+     . 5.775,6.868,8.745,10.429,13.457,22.538,
+     . 2.116,2.116,2.116,2.116,2.882,3.330,
+     . 3.876,4.670,6.059,7.327,9.650,16.883/
+c
+      DO i=1, klon
+         taue670(i)=0.0
+         taue865(i)=0.0
+      ENDDO
+c      
+      DO k=1, klev
+      DO i=1, klon
+         if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k)
+         if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k)         
+        zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+        zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG           ! m
+        rh=MIN(RHcl(i,k)*100.,RH_MAX)
+        RH_num = INT( rh/10. + 1.)
+        IF (rh.LT.0.) STOP 'aeropt: RH < 0 not possible'
+        IF (rh.gt.85.) RH_num=10
+        IF (rh.gt.90.) RH_num=11
+        DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+c                
+        inu=1
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+c
+        inu=2
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+cjq
+cjq for aerosol index
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,4) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,4)-
+     .       alpha_aer_sulfate(RH_num,4)) !--m2/g 
+c     
+        taue670(i)=taue670(i)+
+     .       alphasulfate*msulfate(i,k)*zdz*1.e-6
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,5) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,5)-
+     .       alpha_aer_sulfate(RH_num,5)) !--m2/g 
+c
+        taue865(i)=taue865(i)+
+     .         alphasulfate*msulfate(i,k)*zdz*1.e-6
+        
+      ENDDO
+      ENDDO
+c      
+      DO i=1, klon
+        ai(i)=(-log(MAX(taue670(i),0.0001)/
+     .                MAX(taue865(i),0.0001))/log(670./865.)) * 
+     .        taue865(i)
+      ENDDO     
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ajsec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ajsec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ajsec.F	(revision 984)
@@ -0,0 +1,403 @@
+!
+! $Header$
+!
+      SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+c
+      INTEGER limbas(klon), limhau ! les couches a ajuster
+c
+      LOGICAL mixq
+ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+c
+      REAL zh(klon,klev)
+      REAL zho(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+c
+c Initialisation:
+c
+cym
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c------------------------------------- detection des profils a modifier
+      DO k = 1, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zho(i,k) = zh(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = 2, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i).and.k-1>limbas(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas(i)
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas(i)) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+c
+      DO k = 1, limhau
+      DO i = 1, klon
+         d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+! FH : les d_q et d_t sont maintenant calcules de facon a valoir
+! effectivement 0. si on ne fait rien.
+!
+!     IF (limbas.GT.1) THEN
+!     DO k = 1, limbas-1
+!     DO i = 1, klon
+!        d_t(i,k) = 0.0
+!        d_q(i,k) = 0.0
+!     ENDDO
+!     ENDDO
+!     ENDIF
+c
+!     IF (limhau.LT.klev) THEN
+!     DO k = limhau+1, klev
+!     DO i = 1, klon
+!        d_t(i,k) = 0.0
+!        d_q(i,k) = 0.0
+!     ENDDO
+!     ENDDO
+!     ENDIF
+c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+
+      SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+c
+      INTEGER limbas, limhau ! les couches a ajuster
+ccc      PARAMETER (limbas=klev-3, limhau=klev)
+cym      PARAMETER (limbas=1, limhau=klev)
+c
+      LOGICAL mixq
+ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+c
+      REAL zh(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+c
+c Initialisation:
+c
+cym
+      limbas=1
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c------------------------------------- detection des profils a modifier
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = limbas+1, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      IF (limbas.GT.1) THEN
+      DO k = 1, limbas-1
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (limhau.LT.klev) THEN
+      DO k = limhau+1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL d_t(klon,klev)
+c
+      REAL local_h(klon,klev)
+      REAL hm, sm
+      LOGICAL modif(klon), down
+      INTEGER i, l, l1, l2
+c------------------------------------- detection des profils a modifier
+      DO i = 1, klon
+         modif(i)   = .false.
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
+      ENDDO
+      ENDDO
+c
+      DO l = 2, klev
+      DO i = 1, klon
+         IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
+            modif(i) = .true.
+         ELSE
+            modif(i) = modif(i)
+         ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      do 1080 i = 1, klon
+        if (modif(i)) then
+          l2 = 1
+ 8000     continue
+            l2 = l2 + 1
+            if (l2 .gt. klev) goto 8001
+            if (local_h(i, l2) .lt. local_h(i, l2-1)) then
+              l1 = l2 - 1
+              l  = l1
+              sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1))
+              hm = local_h(i, l2)
+ 8020         continue
+                sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+                hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+     .                         * (local_h(i, l) - hm) / sm
+                down = .false.
+                if (l1 .ne. 1) then
+                  if (hm .lt. local_h(i, l1-1)) then
+                    down = .true.
+                  end if
+                end if
+                if (down) then
+                  l1 = l1 - 1
+                  l  = l1
+                else
+                  if ((l2 .eq. klev)) GOTO 8021
+                  IF ((local_h(i, l2+1).ge.hm)) goto 8021
+                  l2 = l2 + 1
+                  l  = l2
+                end if
+              go to 8020
+ 8021         continue
+c------------ nouveau profil : constant (valeur moyenne)
+              do 1100 l = l1, l2
+                local_h(i, l) = hm
+ 1100         continue
+              l2 = l2 + 1
+            end if
+          go to 8000
+ 8001     continue
+        end if
+ 1080 continue
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/albedo.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/albedo.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/albedo.F	(revision 984)
@@ -0,0 +1,191 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE alboc(rjour,rlat,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+c Date: le 16 mars 1995
+c Objet: Calculer l'albedo sur l'ocean
+c Methode: Integrer numeriquement l'albedo pendant une journee
+c
+c Arguments;
+c rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+c rlat (in,R)   : latitude en degre
+c albedo (out,R): albedo obtenu (de 0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "clesphys.h"
+c
+c fmagic -> clesphys.h/.inc
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7)
+      INTEGER npts ! il controle la precision de l'integration
+      PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+c
+      REAL rlat(klon), rjour, albedo(klon)
+      REAL zdist, zlonsun, zpi, zdeclin
+      REAL rmu,alb, srmu, salb, fauxo, aa, bb
+      INTEGER i, k
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      fauxo = (1.47-ACOS(rmu))/.15
+      alb = 0.03+0.630/(1.+fauxo*fauxo)
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         fauxo = (1.47-ACOS(rmu))/.15
+         alb = 0.03+0.630/(1.+fauxo*fauxo)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic+pmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+  999 CONTINUE
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 1999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+cIM cf. PB  alb = 0.058/(rmu + 0.30)
+c     alb = 0.058/(rmu + 0.30) * 1.5
+      alb = 0.058/(rmu + 0.30) * 1.2
+c     alb = 0.058/(rmu + 0.30) * 1.3
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+cIM cf. PB      alb = 0.058/(rmu + 0.30)
+c        alb = 0.058/(rmu + 0.30) * 1.5
+         alb = 0.058/(rmu + 0.30) * 1.2
+c        alb = 0.058/(rmu + 0.30) * 1.3
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic+pmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+1999  CONTINUE
+      ENDIF
+      RETURN
+      END
+c=====================================================================
+      SUBROUTINE alboc_cd(rmu0,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940624
+c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+c Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+C on radiation in the atmosphere, 19-28 August 1976, science Press,
+C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+c
+c Arguments
+c rmu0    (in): cosinus de l'angle solaire zenithal
+c albedo (out): albedo de surface de l'ocean
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+      REAL rmu0(klon), albedo(klon)
+c
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7) 
+c
+      REAL fauxo
+      INTEGER i
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      DO i = 1, klon
+c
+         rmu0(i) = MAX(rmu0(i),0.0)
+c
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))+pmagic
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      DO i = 1, klon
+         rmu0(i) = MAX(rmu0(i),0.0)
+cIM:orig albedo(i) = 0.058/(rmu0(i) + 0.30)
+         albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)+pmagic
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+      ENDIF
+c
+      RETURN
+      END
+c========================================================================
Index: LMDZ4/tags/LF_20080728/libf/phylmd/albsno.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/albsno.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/albsno.F90	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
+
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN)                  :: klon, knon
+  REAL, INTENT(IN)                     :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+
+! In/Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
+
+! Local variables
+!****************************************************************************************
+  INTEGER                              :: i, nv
+  INTEGER, PARAMETER                   :: nvm = 8 
+  REAL                                 :: as
+  REAL, DIMENSION(klon,nvm)            :: veget
+  REAL, DIMENSION(nvm),SAVE            :: init, decay
+  !$OMP THREADPRIVATE(init, decay)
+
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+!****************************************************************************************
+
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+     alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+     DO i = 1, knon
+        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+     ENDDO
+  ENDDO
+  
+
+! modilation en fonction de l'age de la neige
+  DO i = 1, knon
+     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+     agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+  
+END SUBROUTINE albsno
Index: LMDZ4/tags/LF_20080728/libf/phylmd/atm2geo.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/atm2geo.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/atm2geo.F	(revision 984)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+C
+      SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
+      USE dimphy
+      USE mod_phys_lmdz_para
+      IMPLICIT NONE
+      include 'dimensions.h'
+cc
+cc Change wind local atmospheric coordinates to
+cc geocentric
+cc
+cxxx      INCLUDE 'param.h'
+c
+      INTEGER, INTENT (in)              :: im, jm
+      REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn
+      REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
+      REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz
+c
+      REAL, PARAMETER :: rpi = 3.141592653E0
+      REAL, PARAMETER :: rad = rpi / 180.0E0
+c
+      REAL, DIMENSION (im,jm) :: zsinlon, zcoslon
+      REAL, DIMENSION (im,jm) :: zsinlat, zcoslat
+c
+      LOGICAL, SAVE :: linit = .FALSE.
+c$OMP THREADPRIVATE(linit)
+
+cym utilise pour le couple, ne fonctionne que en MPI seul
+c
+cxxx      IF ( .NOT. linit ) THEN 
+          zsinlon = SIN (rad * plon)
+          zcoslon = COS (rad * plon)
+          zsinlat = SIN (rad * plat)
+          zcoslat = COS (rad * plat)
+          linit = .TRUE.
+cxxx      ENDIF 
+c
+      pxx = - zsinlon * pte - zsinlat * zcoslon * ptn
+      pyy =   zcoslon * pte - zsinlat * zsinlon * ptn
+      pzz =   zcoslat * ptn
+
+c
+c Value at North Pole
+      IF (is_north_pole) THEN
+        pxx ( :,  1) = - ptn ( 1, 1)
+        pyy ( :,  1) = - pte ( 1, 1)
+        pzz ( :,  1) = 0.0
+      ENDIF
+c Value at South Pole
+      
+      IF (is_south_pole) THEN
+        pxx ( :, jm) = + ptn ( 1, jm)
+        pyy ( :, jm) = + pte ( 1, jm)
+        pzz ( :, jm) = 0.0
+      ENDIF
+ 
+      RETURN 
+      END SUBROUTINE atm2geo
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calbeta.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calbeta.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calbeta.F90	(revision 984)
@@ -0,0 +1,103 @@
+!
+! $Header$
+!
+SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
+     vbeta,vcal,vdif)
+
+  USE dimphy
+  IMPLICIT none
+!======================================================================
+! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
+! date: 19940414
+!======================================================================
+!
+! Calculer quelques parametres pour appliquer la couche limite
+! ------------------------------------------------------------
+  INCLUDE "indicesol.h"
+  
+! Variables d'entrees
+!****************************************************************************************
+  REAL, INTENT(IN)                   :: dtime
+  INTEGER, INTENT(IN)                :: indice
+  INTEGER, INTENT(IN)                :: knon
+  REAL, DIMENSION(klon), INTENT(IN)  :: snow
+  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
+
+  
+! Variables de sorties
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
+  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
+  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
+
+! Variables locales
+!****************************************************************************************
+  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
+!cc      PARAMETER (tau_gl=86400.0*30.0)
+  REAL, PARAMETER :: mx_eau_sol=150.0
+  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
+  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
+  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
+  
+  INTEGER         :: i
+
+!****************************************************************************************  
+   
+  vbeta(:) = 0.0
+  vcal(:) = 0.0
+  vdif(:) = 0.0
+  
+  IF (indice.EQ.is_oce) THEN
+     DO i = 1, knon
+        vcal(i)   = 0.0
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_sic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 1.0/tau_gl
+!          vdif(i) = calice/tau_gl ! c'etait une erreur
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_ter) THEN
+     DO i = 1, knon
+        vcal(i) = calsol
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_lic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+END SUBROUTINE calbeta
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calcratqs.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calcratqs.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calcratqs.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE calcratqs ( flag_ratqs,
+     I            paprs,pplay,q_seri,d_t_con,d_t_ajs
+     O           ,ratqs,zpt_conv)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL d_t_con(klon,klev)
+      REAL d_t_ajs(klon,klev)
+      REAL ratqs(klon,klev)
+      LOGICAL pt_conv(klon,klev)
+      REAL q_seri(klon,klev)
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+c$OMP THREADPRIVATE(firstcall)
+
+      REAL ratqsmin,ratqsmax,zx,epmax
+      REAL ratqs1,ratqs2,ratqs3,ratqs4
+      REAL ratqsc1,ratqsc2,ratqsc3,ratqsc4
+      INTEGER i,k
+      INTEGER flag_ratqs
+      save ratqsmin,ratqsmax,epmax
+      save ratqs1,ratqs2,ratqs3,ratqs4
+      save ratqsc1,ratqsc2,ratqsc3,ratqsc4
+c$OMP THREADPRIVATE(ratqsmin,ratqsmax,epmax)
+c$OMP THREADPRIVATE(ratqs1,ratqs2,ratqs3,ratqs4)
+c$OMP THREADPRIVATE(ratqsc1,ratqsc2,ratqsc3,ratqsc4)
+      real zpt_conv(klon,klev)
+
+      REAL zx_min
+      PARAMETER (zx_min=1.0)
+      REAL zx_max
+      PARAMETER (zx_max=0.1)
+
+	zpt_conv=0.
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c
+      if (flag_ratqs.eq.0) then
+
+         ratqsmax=0.01
+         ratqsmin=0.3
+
+         if (firstcall) print*,'RATQS ANCIEN '
+         do k=1,klev
+         do i=1,klon
+            zx = pplay(i,k)/paprs(i,1)
+            zx = (zx_max-zx)/(zx_max-zx_min)
+            zx = MIN(MAX(zx,0.0),1.0)
+            zx = zx * zx * zx
+            ratqs(i,k)= zx * (ratqsmax-ratqsmin) + ratqsmin
+         enddo
+         enddo
+
+      else
+
+c  On aplique un ratqs "interactif" a toutes les mailles affectees
+c  par la convection ou se trouvant "sous" une maille affectee.
+         do i=1,klon
+            pt_conv(i,klev)=.false.
+         enddo
+         do k=klev-1,1,-1
+            do i=1,klon
+               pt_conv(i,k)=pt_conv(i,k+1).or.
+     s               (abs(d_t_con(i,k))+abs(d_t_ajs(i,k))).gt.1.e-8
+               if(pt_conv(i,k)) then
+                  zpt_conv(i,k)=1.
+               else
+                  zpt_conv(i,k)=0.
+               endif
+            enddo
+         enddo
+
+         if (flag_ratqs.eq.1) then
+
+            ratqsmin=0.4
+            ratqsmax=0.99
+            if (firstcall) print*,'RATQS INTERACTIF '
+            do k=1,klev
+                do i=1,klon
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=0.01
+     s                +1.5*0.25*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                      ratqs(i,k)=max(ratqs(i,k),0.1)
+                   else
+                      ratqs(i,k)=0.01+(ratqsmin-0.01)*
+     s             min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.)
+                   endif
+                enddo
+            enddo
+         else if (flag_ratqs.eq.2) then
+            do k=1,klev
+                do i=1,klon
+                   ratqs(i,k)=0.001+
+     s             (q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                   else
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmin)
+                   endif
+                enddo
+            enddo
+         else
+            do k=1,klev
+               do i=1,klon
+                  if (pplay(i,k).ge.95000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc1
+                     else
+                        ratqs(i,k)=ratqs1
+                     endif
+                  else if (pplay(i,k).ge.75000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc2
+                     else
+                        ratqs(i,k)=ratqs2
+                     endif
+                  else if (pplay(i,k).ge.50000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc3
+                     else
+                        ratqs(i,k)=ratqs3
+                     endif
+                  else
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc4
+                     else
+                        ratqs(i,k)=ratqs4
+                     endif
+                  endif
+               enddo
+            enddo
+         endif
+
+      endif
+
+      firstcall=.false.
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calcul_REGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calcul_REGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calcul_REGDYN.h	(revision 984)
@@ -0,0 +1,22 @@
+c
+c $Header$
+c
+c calculs statistiques distribution nuage ftion du regime dynamique 
+c
+c Ce calcul doit etre fait a partir de valeurs mensuelles ??
+      CALL histo_o500_pctau(nbregdyn,pct_ocean,o500,fq_isccp,
+     &histoW,nhistoW)
+c
+c nhistoWt = somme de toutes les nhistoW
+      DO nreg=1, nbregdyn
+       DO k = 1, kmaxm1
+        DO l = 1, lmaxm1
+         DO iw = 1, iwmax
+          nhistoWt(k,l,iw,nreg)=nhistoWt(k,l,iw,nreg)+
+     &    nhistoW(k,l,iw,nreg)
+         ENDDO
+        ENDDO
+       ENDDO
+      ENDDO
+c
+cIM 190504 END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calcul_STDlev.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calcul_STDlev.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calcul_STDlev.h	(revision 984)
@@ -0,0 +1,324 @@
+c
+c $Header$
+c
+c
+cIM on initialise les champs en debut du jour ou du mois 
+c
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,tsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,usumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,phisumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,qsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,rhsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,uvsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vqsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vTsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wqsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vphisumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wTsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,u2sumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,v2sumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,T2sumSTD)
+c
+cIM on interpole sur les niveaux STD de pression a chaque pas de temps de la physique
+c
+       DO k=1, nlevSTD
+c
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .              t_seri,tlevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             u_seri,ulevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             v_seri,vlevSTD(:,k))
+c
+        DO l=1, klev
+        DO i=1, klon
+         zx_tmp_fi3d(i,l)=paprs(i,l)
+        ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,zx_tmp_fi3d,rlevSTD(k),
+     .             omega,wlevSTD(:,k))
+c
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zphi/RG,philevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             qx(:,:,ivap),qlevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_rh*100.,rhlevSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,uvSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*q_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vqSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vTSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*qx(i,l,ivap)
+         ENDDO !i 
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,wqSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*zphi(i,l)/RG
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vphiSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,wTSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*u_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,u2STD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,v2STD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=t_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,T2STD(:,k))
+c
+       ENDDO !k=1,nlevSTD
+c
+cIM on somme les valeurs definies a chaque pas de temps de la physique ou 
+cIM toutes les 6 heures
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.TRUE.
+       CALL undefSTD(nlevSTD,itap,tlevSTD,
+     $               dtime,ecrit_hf,
+     $               oknondef,tnondef,tsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,ulevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,usumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,philevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,phisumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,qlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,qsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,rhlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,rhsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,uvSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,uvsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vqSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vqsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vTSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vTsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wqSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wqsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vphiSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vphisumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wTSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wTsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,u2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,u2sumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,v2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,v2sumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,T2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,T2sumSTD)
+c
+cIM on moyenne a la fin du jour ou du mois 
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,tsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,usumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,phisumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,qsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,rhsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,uvsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vqsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vTsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wqsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vphisumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wTsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,u2sumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,v2sumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,T2sumSTD)
+c
+cIM interpolation a chaque pas de temps du SWup(clr) et SWdn(clr) a 200 hPa
+c
+      CALL plevel(klon,klevp1,.true.,paprs,20000.,
+     $     swdn0,SWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swdn,SWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swup0,SWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swup,SWup200)
+c
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwdn0,LWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwdn,LWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwup0,LWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwup,LWup200)
+c
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calcul_divers.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calcul_divers.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calcul_divers.h	(revision 984)
@@ -0,0 +1,29 @@
+c
+c $Header$
+c
+c
+c initialisations diverses au "debut" du mois
+c
+      IF(MOD(itap,INT(ecrit_mth)).EQ.1) THEN
+         DO i=1, klon
+          nday_rain(i)=0.
+         ENDDO !i
+c
+c surface terre
+       DO i=1, klon
+         IF(pctsrf_new(i,is_ter).GT.0.) THEN
+            paire_ter(i)=airephy(i)*pctsrf_new(i,is_ter)
+         ENDIF 
+       ENDDO
+c
+      ENDIF !MOD(itap,INT(ecrit_mth)).EQ.1
+c
+      IF(MOD(itap,INT(ecrit_day)).EQ.0) THEN
+c
+cIM calcul total_rain, nday_rain
+c
+       DO i = 1, klon
+        total_rain(i)=rain_fall(i)+snow_fall(i)  
+        IF(total_rain(i).GT.0.) nday_rain(i)=nday_rain(i)+1.
+       ENDDO
+      ENDIF !itap.EQ.ecrit_mth
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calcul_fluxs_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calcul_fluxs_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calcul_fluxs_mod.F90	(revision 984)
@@ -0,0 +1,246 @@
+!
+! $Header$
+!
+MODULE calcul_fluxs_mod
+
+
+CONTAINS
+  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
+       tsurf, p1lay, cal, beta, coef1lay, ps, &
+       precip_rain, precip_snow, snow, qsurf, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    USE dimphy, ONLY : klon
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   qsurf        humidite de l'air au dessus du sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon, nisurf
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
+    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
+
+! Parametres entree-sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
+
+! Parametres sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
+
+! Variables locales
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
+    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
+    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+    REAL, DIMENSION(klon)                :: zx_sl, zx_k1
+    REAL, DIMENSION(klon)                :: d_ts
+    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+    REAL                                 :: qsat_new, q1_new
+    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
+    REAL, PARAMETER                      :: max_eau_sol = 150.0
+    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
+    LOGICAL                              :: fonte_neige
+    LOGICAL, SAVE                        :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! End definition
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
+    
+    IF (check) THEN
+       WRITE(*,*)' radsol (min, max)', &
+            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
+       CALL flush(6)
+    ENDIF
+  
+! Traitement neige et humidite du sol
+!****************************************************************************************
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!****************************************************************************************
+    evap = 0.
+    fluxsens=0.
+    fluxlat=0.
+    dflux_s = 0.
+    dflux_l = 0.	
+!
+! zx_qs = qsat en kg/kg
+!****************************************************************************************
+    DO i = 1, knon
+       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+       IF (thermcep) THEN
+          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+          zx_qs=MIN(0.5,zx_qs)
+          zcor=1./(1.-retv*zx_qs)
+          zx_qs=zx_qs*zcor
+          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+               /RLVTT / zx_pkh(i)
+       ELSE
+          IF (tsurf(i).LT.t_coup) THEN
+             zx_qs = qsats(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ELSE
+             zx_qs = qsatl(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ENDIF
+       ENDIF
+       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+       zx_qsat(i) = zx_qs
+       zx_coef(i) = coef1lay(i) * &
+            (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
+            p1lay(i)/(RD*t1lay(i))
+       
+    ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!****************************************************************************************
+
+    DO i = 1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+       zx_k1(i) = zx_coef(i)
+    ENDDO
+    
+
+    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)
+       zx_nq(i) = beta(i) * zx_k1(i) * (-1. * 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)
+     
+! Tsurface
+       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+            + dif_grnd(i) * t_grnd * dtime)/ &
+            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+            + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+       d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+       fluxlat(i) = - evap(i) * zx_sl(i)
+       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+       
+! Derives des flux dF/dTs (W m-2 K-1):
+       dflux_s(i) = zx_nh(i)
+       dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+! Nouvelle valeure de l'humidite au dessus du sol
+       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
+       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+    ENDDO
+!
+!****************************************************************************************
+!
+  END SUBROUTINE calcul_fluxs
+
+END MODULE calcul_fluxs_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calcul_simulISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calcul_simulISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calcul_simulISCCP.h	(revision 984)
@@ -0,0 +1,168 @@
+c
+c $Header$
+c
+c on appelle le simulateur ISCCP toutes les 3h
+c et on fait des sorties 1 fois par jour 
+c
+c ATTENTION : le temps de calcul peut augmenter considerablement !
+c =============================================================== c
+      DO n=1, napisccp
+c
+      nbapp_isccp=30 !appel toutes les 15h
+cIM 170107      isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique
+      freqin_pdt(n)=ifreq_isccp(n)
+c
+cIM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee
+c
+      DO i=1, klon
+       sunlit(i)=1 
+       IF(rmu0(i).EQ.0.) sunlit(i)=0
+       nbsunlit(1,i,n)=FLOAT(sunlit(i))
+      ENDDO
+c
+cIM calcul tau, emissivite nuages convectifs
+c
+      convfra(:,:)=rnebcon(:,:)
+      convliq(:,:)=rnebcon(:,:)*clwcon(:,:)
+c
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, convliq, convfra, dtau_c, dem_c,
+     .            cldh_c, cldl_c, cldm_c, cldt_c, cldq_c,
+     .            flwp_c, fiwp_c, flwc_c, fiwc_c,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+c
+cIM calcul tau, emissivite nuages startiformes
+c
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, dtau_s, dem_s,
+     .            cldh_s, cldl_s, cldm_s, cldt_s, cldq_s,
+     .            flwp_s, fiwp_s, flwc_s, fiwc_s,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+c
+      cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+c
+cIM inversion des niveaux de pression ==> de haut en bas
+c
+      CALL haut2bas(klon, klev, pplay, pfull)
+      CALL haut2bas(klon, klev, q_seri, qv)
+      CALL haut2bas(klon, klev, cldtot, cc)
+      CALL haut2bas(klon, klev, rnebcon, conv)
+      CALL haut2bas(klon, klev, dtau_s, dtau_sH2B)
+      CALL haut2bas(klon, klev, dtau_c, dtau_cH2B)
+      CALL haut2bas(klon, klev, t_seri, at)
+      CALL haut2bas(klon, klev, dem_s, dem_sH2B)
+      CALL haut2bas(klon, klev, dem_c, dem_cH2B)
+      CALL haut2bas(klon, klevp1, paprs, phalf)
+c
+cIM lecture invtau, tautab des fichiers formattes
+c
+      IF (debut) THEN
+c$OMP MASTER
+c     open(99,file='tautab.bin',access='sequential',
+c    $     form='unformatted',status='old')
+c     read(99) tautab_omp
+c
+      open(99,file='tautab.formatted', FORM='FORMATTED')
+      read(99,'(f30.20)') tautab_omp
+      close(99)
+c
+      open(99,file='invtau.formatted',form='FORMATTED')
+      read(99,'(i10)') invtau_omp
+      close(99)
+c$OMP END MASTER
+c$OMP BARRIER
+      tautab=tautab_omp
+      invtau=invtau_omp
+c
+      ENDIF !debut
+c
+cIM: initialisation de seed
+c
+        DO i=1, klon
+c
+         aa=ABS(paprs(i,2)-NINT(paprs(i,2)))
+         seed_re(i,n)=1000.*aa+1.
+         seed(i,n)=NINT(seed_re(i,n))
+c
+         IF(seed(i,n).LT.50) THEN
+c          print*,'seed<50 avant i seed itap paprs',i,
+c    .     seed(i,n),itap,paprs(i,2)
+           seed(i,n)=50+seed(i,n)+i+itap
+           seed_old(i,n)=seed(i,n)
+c
+           IF(itap.GT.1) then
+            IF(seed(i,n).EQ.seed_old(i,n)) THEN
+             seed(i,n)=seed(i,n)+10
+             seed_old(i,n)=seed(i,n)
+            ENDIF
+           ENDIF
+c
+c          print*,'seed<50 apres i seed itap paprs',i,
+c    .     seed(i,n),itap,paprs(i,2)
+c
+          ELSE IF(seed(i,n).EQ.0) THEN
+           print*,'seed=0 i paprs aa seed_re',
+     .     i,paprs(i,2),aa,seed_re(i,n)
+           STOP
+          ELSE IF(seed(i,n).LT.0) THEN
+           print*,'seed < 0, i seed itap paprs',i,
+     .     seed(i,n),itap,paprs(i,2)
+           STOP
+          ENDIF
+c
+        ENDDO
+c     
+cIM: pas de debug, debugcol
+      debug=0
+      debugcol=0
+c
+cIM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa)
+c
+        DO k=1, klevm1
+        kp1=k+1
+c       PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1)
+        if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN
+         DO i=1, klon
+          o500(i)=omega(i,k)*RDAY/100.
+c         if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1)
+         ENDDO
+         GOTO 1000
+        endif 
+1000  continue
+      ENDDO
+c
+cIM recalcule les nuages vus par satellite, via le simulateur ISCCP
+c
+      CALL ISCCP_CLOUD_TYPES(
+     &     debug,
+     &     debugcol,
+     &     klon,
+     &     sunlit,
+     &     klev,
+     &     ncol(n),
+     &     seed(:,n),
+     &     pfull,
+     &     phalf,
+     &     qv, cc, conv, dtau_sH2B, dtau_cH2B,
+     &     top_height,
+     &     overlap,
+     &     tautab,
+     &     invtau,
+     &     ztsol,
+     &     emsfc_lw,
+     &     at, dem_sH2B, dem_cH2B,
+     &     fq_isccp(:,:,:,n),
+     &     totalcldarea(:,n),
+     &     meanptop(:,n),
+     &     meantaucld(:,n),
+     &     boxtau(:,:,n),
+     &     boxptop(:,:,n))
+c
+      ENDDO !n=1, napisccp
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calltherm.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calltherm.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calltherm.F90	(revision 984)
@@ -0,0 +1,361 @@
+!
+! $Header$
+!
+      subroutine calltherm(dtime  &
+     &      ,pplay,paprs,pphi,weak_inversion  &
+     &      ,u_seri,v_seri,t_seri,q_seri,zqsat,debut  &
+     &      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs  &
+     &      ,fm_therm,entr_therm,detr_therm,zqasc,clwcon0,lmax,ratqscth,  &
+     &       ratqsdiff,zqsatth,Ale_bl,Alp_bl,lalim_conv,wght_th, &
+     &       zmax0,f0)
+
+      USE dimphy
+      implicit none
+#include "dimensions.h"
+!#include "dimphy.h"
+#include "thermcell.h"
+#include "iniprint.h"
+
+!  A inclure eventuellement dans les fichiers de configuration
+      data r_aspect_thermals,l_mix_thermals/2.,30./
+      data w2di_thermals/1/
+
+!IM 140508
+      INTEGER itap
+      REAL dtime
+      LOGICAL debut
+      LOGICAL logexpr0, logexpr2(klon,klev), logexpr1(klon)
+      REAL fact(klon)
+      INTEGER nbptspb
+
+      REAL u_seri(klon,klev),v_seri(klon,klev)
+      REAL t_seri(klon,klev),q_seri(klon,klev),qmemoire(klon,klev)
+      REAL weak_inversion(klon)
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      real zlev(klon,klev+1) 
+!test: on sort lentr et a* pour alimenter KE
+      REAL wght_th(klon,klev)
+      INTEGER lalim_conv(klon)
+
+!FH Update Thermiques
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_u_ajs(klon,klev),d_v_ajs(klon,klev)
+      real fm_therm(klon,klev+1)
+      real entr_therm(klon,klev),detr_therm(klon,klev)
+
+!********************************************************
+!     declarations
+      real fmc_therm(klon,klev+1),zqasc(klon,klev)
+      real zqla(klon,klev)
+      real wmax_sec(klon)
+      real zmax_sec(klon)
+      real f_sec(klon)
+      real detrc_therm(klon,klev)
+! FH WARNING : il semble que ces save ne servent a rien
+!     save fmc_therm, detrc_therm
+      real clwcon0(klon,klev)
+      real zqsat(klon,klev)
+      real zw_sec(klon,klev+1)
+      integer lmix_sec(klon)
+      integer lmax(klon)
+      real ratqscth(klon,klev)
+      real ratqsdiff(klon,klev)
+      real zqsatth(klon,klev)  
+!nouvelles variables pour la convection
+      real Ale_bl(klon)
+      real Alp_bl(klon)
+      real Ale(klon)
+      real Alp(klon)
+!RC
+      !on garde le zmax du pas de temps precedent
+      real zmax0(klon), f0(klon)
+!********************************************************
+
+
+! variables locales
+      REAL d_t_the(klon,klev), d_q_the(klon,klev)
+      REAL d_u_the(klon,klev),d_v_the(klon,klev)
+!
+      real zfm_therm(klon,klev+1),zdt
+      real zentr_therm(klon,klev),zdetr_therm(klon,klev)
+! FH A VERIFIER : SAVE INUTILES
+!      save zentr_therm,zfm_therm
+
+      integer i,k
+      logical, save :: first=.true.
+!********************************************************
+      if (first) then
+        itap=0
+        first=.false.
+      endif
+
+! Incrementer le compteur de la physique
+     itap   = itap + 1
+
+!  Modele du thermique
+!  ===================
+!         print*,'thermiques: WARNING on passe t au lieu de t_seri'
+
+
+! On prend comme valeur initiale des thermiques la valeur du pas
+! de temps precedent
+         zfm_therm(:,:)=fm_therm(:,:)
+         zdetr_therm(:,:)=detr_therm(:,:)
+         zentr_therm(:,:)=entr_therm(:,:)
+
+! On reinitialise les flux de masse a zero pour le cumul en
+! cas de splitting
+         fm_therm(:,:)=0.
+         entr_therm(:,:)=0.
+         detr_therm(:,:)=0.
+
+         Ale_bl(:)=0.
+         Alp_bl(:)=0.
+         if (prt_level.ge.10) then
+          print*,'thermV4 nsplit: ',nsplit_thermals,' weak_inversion'
+         endif
+
+!   tests sur les valeurs negatives de l'eau
+         logexpr0=prt_level.ge.10
+         nbptspb=0
+         do k=1,klev
+            do i=1,klon
+               logexpr2(i,k)=.not.q_seri(i,k).ge.0.
+               if (logexpr2(i,k)) then
+                q_seri(i,k)=1.e-15
+                nbptspb=nbptspb+1
+               endif
+!               if (logexpr0) &
+!    &             print*,'WARN eau<0 avant therm i=',i,'  k=',k  &
+!    &         ,' dq,q',d_q_the(i,k),q_seri(i,k)
+            enddo
+         enddo
+         if(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb   
+
+         zdt=dtime/float(nsplit_thermals)
+         do isplit=1,nsplit_thermals
+
+          if (iflag_thermals.eq.1) then
+            CALL thermcell_2002(klon,klev,zdt   &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,30.,w2di_thermals  &
+     &      ,tau_thermals,3)
+          else if (iflag_thermals.eq.2) then
+            CALL thermcell_sec(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,zlev  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,30.,w2di_thermals  &
+     &      ,tau_thermals,3)
+          else if (iflag_thermals.eq.3) then
+            CALL thermcell(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tau_thermals,3)
+          else if (iflag_thermals.eq.10) then
+            CALL thermcell_eau(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tau_thermals,3)
+          else if (iflag_thermals.eq.11) then
+            stop'cas non prevu dans calltherm'
+!           CALL thermcell_pluie(klon,klev,zdt  &
+!   &      ,pplay,paprs,pphi,zlev  &
+!    &      ,u_seri,v_seri,t_seri,q_seri  &
+!    &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+!    &      ,zfm_therm,zentr_therm,zqla  &
+!    &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+!    &      ,tau_thermals,3)
+          else if (iflag_thermals.eq.12) then
+            CALL calcul_sec(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,zlev  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,zmax_sec,wmax_sec,zw_sec,lmix_sec  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tau_thermals)
+!            CALL calcul_sec_entr(klon,klev,zdt
+!     s      ,pplay,paprs,pphi,zlev,debut
+!     s      ,u_seri,v_seri,t_seri,q_seri                
+!     s      ,zmax_sec,wmax_sec,zw_sec,lmix_sec
+!     s      ,r_aspect_thermals,l_mix_thermals,w2di_thermals
+!     s      ,tau_thermals,3)
+!           CALL thermcell_pluie_detr(klon,klev,zdt  &
+!    &      ,pplay,paprs,pphi,zlev,debut  &
+!    &      ,u_seri,v_seri,t_seri,q_seri  &
+!    &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+!    &      ,zfm_therm,zentr_therm,zqla,lmax  &
+!    &      ,zmax_sec,wmax_sec,zw_sec,lmix_sec  &
+!    &      ,ratqscth,ratqsdiff,zqsatth  &
+!    &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+!    &      ,tau_thermals)
+          else if (iflag_thermals.ge.13) then
+            CALL thermcell_main(itap,klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,debut  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm,zdetr_therm,zqla,lmax  &
+     &      ,ratqscth,ratqsdiff,zqsatth  &
+     &      ,r_aspect_thermals,l_mix_thermals  &
+     &      ,tau_thermals,Ale,Alp,lalim_conv,wght_th &
+     &      ,zmax0,f0)
+         endif
+
+
+      fact(:)=0.
+      DO i=1,klon
+       logexpr1(i)=iflag_thermals.lt.14.or.weak_inversion(i).gt.0.5
+       IF(logexpr1(i)) fact(i)=1./float(nsplit_thermals)
+      ENDDO
+
+     DO k=1,klev
+!  transformation de la derivee en tendance
+            d_t_the(:,k)=d_t_the(:,k)*dtime*fact(:)
+            d_u_the(:,k)=d_u_the(:,k)*dtime*fact(:)
+            d_v_the(:,k)=d_v_the(:,k)*dtime*fact(:)
+            d_q_the(:,k)=d_q_the(:,k)*dtime*fact(:)
+            fm_therm(:,k)=fm_therm(:,k)  &
+     &      +zfm_therm(:,k)*fact(:)
+            entr_therm(:,k)=entr_therm(:,k)  &
+     &       +zentr_therm(:,k)*fact(:)
+      ENDDO
+       fm_therm(:,klev+1)=0.
+
+
+
+!  accumulation de la tendance
+            d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_the(:,:)
+            d_u_ajs(:,:)=d_u_ajs(:,:)+d_u_the(:,:)
+            d_v_ajs(:,:)=d_v_ajs(:,:)+d_v_the(:,:)
+            d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_the(:,:)
+
+!  incrementation des variables meteo
+            t_seri(:,:) = t_seri(:,:) + d_t_the(:,:)
+            u_seri(:,:) = u_seri(:,:) + d_u_the(:,:)
+            v_seri(:,:) = v_seri(:,:) + d_v_the(:,:)
+            qmemoire(:,:)=q_seri(:,:)
+            q_seri(:,:) = q_seri(:,:) + d_q_the(:,:)
+
+       DO i=1,klon
+        if(prt_level.GE.10) print*,'calltherm i Alp_bl Alp Ale_bl Ale',i,Alp_bl(i),Alp(i),Ale_bl(i),Ale(i)
+            fm_therm(i,klev+1)=0.
+            Ale_bl(i)=Ale_bl(i)+Ale(i)/float(nsplit_thermals)
+!            write(22,*)'ALE CALLTHERM',Ale_bl(i),Ale(i)
+            Alp_bl(i)=Alp_bl(i)+Alp(i)/float(nsplit_thermals)
+!            write(23,*)'ALP CALLTHERM',Alp_bl(i),Alp(i)
+       ENDDO
+
+!IM 060508 marche pas comme cela !!!        enddo ! isplit
+
+!   tests sur les valeurs negatives de l'eau
+         nbptspb=0
+            DO k = 1, klev
+            DO i = 1, klon
+               logexpr2(i,k)=.not.q_seri(i,k).ge.0.
+               if (logexpr2(i,k)) then
+                q_seri(i,k)=1.e-15
+                nbptspb=nbptspb+1
+!                if (prt_level.ge.10) then
+!                  print*,'WARN eau<0 apres therm i=',i,'  k=',k  &
+!    &         ,' dq,q',d_q_the(i,k),q_seri(i,k),  &
+!    &         'fm=',zfm_therm(i,k),'entr=',entr_therm(i,k)
+                 endif
+!       stop
+            ENDDO
+            ENDDO
+        IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb   
+! tests sur les valeurs de la temperature
+        nbptspb=0
+            DO k = 1, klev
+            DO i = 1, klon
+               logexpr2(i,k)=t_seri(i,k).lt.50..or.t_seri(i,k).gt.370.
+               if (logexpr2(i,k)) nbptspb=nbptspb+1
+!              if ((t_seri(i,k).lt.50.) .or.  &
+!    &              (t_seri(i,k).gt.370.)) then
+!                 print*,'WARN temp apres therm i=',i,'  k=',k  &
+!    &         ,' t_seri',t_seri(i,k)
+!              CALL abort
+!              endif
+            ENDDO
+            ENDDO
+        IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb
+         enddo ! isplit
+
+!
+!***************************************************************
+!     calcul du flux ascencant conservatif
+!            print*,'<<<<calcul flux ascendant conservatif'
+
+      fmc_therm=0.
+               do k=1,klev
+            do i=1,klon
+                  if (entr_therm(i,k).gt.0.) then
+                     fmc_therm(i,k+1)=fmc_therm(i,k)+entr_therm(i,k)
+                  else
+                     fmc_therm(i,k+1)=fmc_therm(i,k)
+                  endif
+                  detrc_therm(i,k)=(fmc_therm(i,k+1)-fm_therm(i,k+1))  &
+     &                 -(fmc_therm(i,k)-fm_therm(i,k))
+               enddo
+            enddo
+      
+     
+!****************************************************************
+!     calcul de l'humidite dans l'ascendance
+!      print*,'<<<<calcul de lhumidite dans thermique'
+!CR:on ne le calcule que pour le cas sec
+      if (iflag_thermals.le.11) then      
+      do i=1,klon
+         zqasc(i,1)=q_seri(i,1)
+         do k=2,klev
+            if (fmc_therm(i,k+1).gt.1.e-6) then
+               zqasc(i,k)=(fmc_therm(i,k)*zqasc(i,k-1)  &
+     &              +entr_therm(i,k)*q_seri(i,k))/fmc_therm(i,k+1)
+!CR:test on asseche le thermique
+!               zqasc(i,k)=zqasc(i,k)/2.
+!            else
+!               zqasc(i,k)=q_seri(i,k)
+            endif
+         enddo
+       enddo
+      
+
+!     calcul de l'eau condensee dans l'ascendance
+!             print*,'<<<<calcul de leau condensee dans thermique'
+             do i=1,klon
+                do k=1,klev
+                   clwcon0(i,k)=zqasc(i,k)-zqsat(i,k)
+                   if (clwcon0(i,k).lt.0. .or.   &
+     &             (fm_therm(i,k+1)+detrc_therm(i,k)).lt.1.e-6) then
+                      clwcon0(i,k)=0.
+                   endif
+                enddo
+             enddo
+       else
+              do i=1,klon
+                do k=1,klev
+                   clwcon0(i,k)=zqla(i,k)  
+                   if (clwcon0(i,k).lt.0. .or.   &
+     &             (fm_therm(i,k+1)+detrc_therm(i,k)).lt.1.e-6) then
+                   clwcon0(i,k)=0. 
+                   endif
+                enddo
+             enddo
+       endif
+!*******************************************************************    
+
+
+      return
+
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/calwake.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/calwake.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/calwake.F	(revision 984)
@@ -0,0 +1,466 @@
+      SUBROUTINE CALWAKE(paprs,pplay,dtime
+     :             ,t,q,omgb
+     :             ,dt_dwn,dq_dwn,M_dwn,M_up
+     :             ,dt_a,dq_a,sigd
+     :             ,wdt_PBL,wdq_PBL
+     :             ,udt_PBL,udq_PBL
+     o             ,wake_deltat,wake_deltaq,wake_dth
+     o             ,wake_h,wake_s,wake_dens
+     o             ,wake_pe,wake_fip,wake_gfl
+     o             ,dt_wake,dq_wake
+     o             ,wake_k
+     o             ,undi_t,undi_q
+     o             ,wake_omgbdth,wake_dp_omgb
+     o             ,wake_dtKE,wake_dqKE
+     o             ,wake_dtPBL,wake_dqPBL
+     o             ,wake_omg,wake_dp_deltomg
+     o             ,wake_spread,wake_Cstar,wake_d_deltat_gw
+     o             ,wake_ddeltat,wake_ddeltaq)
+***************************************************************
+*                                                             *
+* CALWAKE                                                     *
+*           interface avec le schema de calcul de la poche    *
+*           froide                                            *
+*                                                             *
+* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+* modified by :  ROEHRIG Romain,    01/30/2007                *
+***************************************************************
+*
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+#include "dimensions.h"
+!#include "dimphy.h"
+#include "YOMCST.h"
+
+c Arguments
+c----------
+
+      INTEGER  i,l,ktopw(klon)
+      REAL   dtime
+
+      REAL paprs(klon,klev+1),pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
+      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev), dq_a(klon,klev)
+      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
+      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
+      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
+      REAL dt_wake(klon,klev),dq_wake(klon,klev)
+      REAL wake_d_deltat_gw(klon,klev)
+      REAL wake_h(klon),wake_s(klon)
+      REAL wake_dth(klon,klev)
+      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
+      REAL undi_t(klon,klev),undi_q(klon,klev)
+      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
+      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
+      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
+      REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev)
+      REAL wake_spread(klon,klev),wake_Cstar(klon)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL d_deltatw(klon,klev), d_deltaqw(klon,klev)
+      INTEGER wake_k(klon)
+      REAL sigd(klon)
+      REAL wake_dens(klon)
+
+C  Variable internes
+C  -----------------
+
+      REAL aire
+      REAL p(klon,klev),ph(klon,klev+1),pi(klon,klev)
+      REAL te(klon,klev),qe(klon,klev),omgbe(klon,klev)
+      REAL dtdwn(klon,klev),dqdwn(klon,klev)
+      REAL dta(klon,klev),dqa(klon,klev)
+      REAL wdtPBL(klon,klev),wdqPBL(klon,klev)
+      REAL udtPBL(klon,klev),udqPBL(klon,klev) 
+      REAL amdwn(klon,klev),amup(klon,klev)
+      REAL dtw(klon,klev),dqw(klon,klev),dth(klon,klev)
+      REAL d_deltat_gw(klon,klev)
+      REAL dtls(klon,klev),dqls(klon,klev)
+      REAL tu(klon,klev),qu(klon,klev)
+      REAL hw(klon),sigmaw(klon),wape(klon),fip(klon),gfl(klon)
+      REAL omgbdth(klon,klev),dp_omgb(klon,klev)
+      REAL dtKE(klon,klev),dqKE(klon,klev)
+      REAL dtPBL(klon,klev),dqPBL(klon,klev)
+      REAL omg(klon,klev+1),dp_deltomg(klon,klev),spread(klon,klev)
+      REAL Cstar(klon)
+      REAL sigd0(klon),wdens(klon)
+
+      REAL RDCP
+
+c      print *, '-> calwake, wake_s ', wake_s(1)
+
+      RDCP=1./3.5
+
+c-----------------------------------------------------------
+cIM 290108     DO 999 i=1,klon   ! a vectoriser
+c----------------------------------------------------------
+
+
+      DO l=1,klev
+      DO i=1,klon 
+        p(i,l)= pplay(i,l)
+        ph(i,l)= paprs(i,l)
+        pi(i,l) = (pplay(i,l)/100000.)**RDCP
+
+        te(i,l) = t(i,l)
+        qe(i,l) = q(i,l)
+        omgbe(i,l) = omgb(i,l)
+
+        dtdwn(i,l)= dt_dwn(i,l)
+        dqdwn(i,l)= dq_dwn(i,l)
+        dta(i,l)= dt_a(i,l)
+        dqa(i,l)= dq_a(i,l)
+        wdtPBL(i,l)= wdt_PBL(i,l)
+        wdqPBL(i,l)= wdq_PBL(i,l)
+        udtPBL(i,l)= udt_PBL(i,l)
+        udqPBL(i,l)= udq_PBL(i,l)
+      ENDDO
+      ENDDO
+      
+      DO i=1,klon 
+      sigd0(i)=sigd(i)
+      ENDDO
+c      print*, 'sigd0,sigd', sigd0, sigd(i)
+      DO i=1,klon 
+      ph(i,klev+1)=0.
+      ENDDO
+
+      DO i=1,klon 
+      ktopw(i) = wake_k(i)
+      ENDDO
+
+      DO l=1,klev
+      DO i=1,klon 
+        dtw(i,l) = wake_deltat(i,l)
+        dqw(i,l) = wake_deltaq(i,l)
+      ENDDO
+      ENDDO
+
+      DO l=1,klev
+      DO i=1,klon 
+        dtls(i,l)=dt_wake(i,l)
+        dqls(i,l)=dq_wake(i,l)
+      ENDDO
+      ENDDO
+
+      DO i=1,klon 
+      hw(i) = wake_h(i)
+      sigmaw(i)= wake_s(i)
+      ENDDO
+
+cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+cfkc  on veut le flux de masse au milieu des couches
+
+      DO l=1,klev-1
+      DO i=1,klon 
+        amdwn(i,l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
+        amdwn(i,l)= (M_dwn(i,l+1))
+      ENDDO
+      ENDDO
+
+c au sommet le flux de masse est nul
+
+      DO i=1,klon 
+      amdwn(i,klev)=0.5*M_dwn(i,klev)
+      ENDDO
+c
+      DO l = 1,klev
+      DO i=1,klon 
+        amup(i,l)=M_up(i,l)
+      ENDDO
+      ENDDO
+
+      call WAKE(p,ph,pi,dtime,sigd0
+     $                ,te,qe,omgbe
+     $                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     $                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     $                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl
+     $                ,dtls,dqls,ktopw
+     $                ,omgbdth,dp_omgb,wdens
+     $                ,tu,qu
+     $                ,dtKE,dqKE
+     $                ,dtPBL,dqPBL
+     $                ,omg,dp_deltomg,spread
+     $                ,Cstar,d_deltat_gw
+     $                ,d_deltatw,d_deltaqw)
+
+      DO i=1,klon 
+       IF (ktopw(i) .GT. 0) THEN
+         DO l=1,klev
+           wake_deltat(i,l)= dtw(i,l)
+           wake_deltaq(i,l)= dqw(i,l)
+           wake_d_deltat_gw(i,l)= d_deltat_gw(i,l)
+           wake_omgbdth(i,l) = omgbdth(i,l)
+           wake_dp_omgb(i,l) = dp_omgb(i,l)
+           wake_dtKE(i,l) = dtKE(i,l)
+           wake_dqKE(i,l) = dqKE(i,l)
+ 	   wake_dtPBL(i,l) = dtPBL(i,l)
+	   wake_dqPBL(i,l) = dqPBL(i,l)
+           wake_omg(i,l) = omg(i,l)
+           wake_dp_deltomg(i,l) = dp_deltomg(i,l)
+           wake_spread(i,l) = spread(i,l)
+           wake_dth(i,l) = dth(i,l)
+           dt_wake(i,l) = dtls(i,l)
+           dq_wake(i,l) = dqls(i,l)
+           undi_t(i,l) = tu(i,l)
+           undi_q(i,l) = qu(i,l)
+           wake_ddeltat(i,l) = d_deltatw(i,l)
+           wake_ddeltaq(i,l) = d_deltaqw(i,l)
+         ENDDO
+       ELSE
+         DO l = 1,klev
+           wake_deltat(i,l)= 0.
+           wake_deltaq(i,l)= 0.
+           wake_d_deltat_gw(i,l)= 0.
+           wake_omgbdth(i,l) = 0.
+           wake_dp_omgb(i,l) = 0.
+           wake_dtKE(i,l) = 0.
+           wake_dqKE(i,l) = 0.
+           wake_omg(i,l) = 0.
+           wake_dp_deltomg(i,l) = 0.
+           wake_spread(i,l) = 0.
+           wake_dth(i,l)=0.
+           dt_wake(i,l)=0.
+           dq_wake(i,l)=0.
+           undi_t(i,l)=te(i,l)
+           undi_q(i,l)=qe(i,l)
+         ENDDO
+       ENDIF
+
+       wake_h(i)= hw(i)
+       wake_s(i)= sigmaw(i)
+       wake_pe(i)= wape(i)
+       wake_fip(i)= fip(i)
+       wake_gfl(i) = gfl(i)
+       wake_k(i) =ktopw(i)
+       wake_Cstar(i) = Cstar(i)
+       wake_dens(i) = wdens(i)
+c
+cIM 290108 999  CONTINUE
+c
+      ENDDO
+      RETURN
+      END
+      SUBROUTINE CALWAKE_scal(paprs,pplay,dtime
+     :             ,t,q,omgb
+     :             ,dt_dwn,dq_dwn,M_dwn,M_up
+     :             ,dt_a,dq_a,sigd
+     :             ,wdt_PBL,wdq_PBL
+     :             ,udt_PBL,udq_PBL
+     o             ,wake_deltat,wake_deltaq,wake_dth
+     o             ,wake_h,wake_s,wake_dens
+     o             ,wake_pe,wake_fip,wake_gfl
+     o             ,dt_wake,dq_wake
+     o             ,wake_k
+     o             ,undi_t,undi_q
+     o             ,wake_omgbdth,wake_dp_omgb
+     o             ,wake_dtKE,wake_dqKE
+     o             ,wake_dtPBL,wake_dqPBL
+     o             ,wake_omg,wake_dp_deltomg
+     o             ,wake_spread,wake_Cstar,wake_d_deltat_gw
+     o             ,wake_ddeltat,wake_ddeltaq)
+***************************************************************
+*                                                             *
+* CALWAKE                                                     *
+*           interface avec le schema de calcul de la poche    *
+*           froide                                            *
+*                                                             *
+* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+* modified by :  ROEHRIG Romain,    01/30/2007                *
+***************************************************************
+*
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c Arguments
+c----------
+
+      INTEGER  i,l,ktopw
+      REAL   dtime
+
+      REAL paprs(klon,klev+1),pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
+      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev), dq_a(klon,klev)
+      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
+      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
+      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
+      REAL dt_wake(klon,klev),dq_wake(klon,klev)
+      REAL wake_d_deltat_gw(klon,klev)
+      REAL wake_h(klon),wake_s(klon)
+      REAL wake_dth(klon,klev)
+      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
+      REAL undi_t(klon,klev),undi_q(klon,klev)
+      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
+      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
+      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
+      REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev)
+      REAL wake_spread(klon,klev),wake_Cstar(klon)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL d_deltatw(klev), d_deltaqw(klev)
+      INTEGER wake_k(klon)
+      REAL sigd(klon)
+      REAL wake_dens(klon)
+
+C  Variable internes
+C  -----------------
+
+      REAL aire
+      REAL p(klev),ph(klev+1),pi(klev)
+      REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev)
+      REAL dta(klev),dqa(klev)
+      REAL wdtPBL(klev),wdqPBL(klev)
+      REAL udtPBL(klev),udqPBL(klev) 
+      REAL amdwn(klev),amup(klev)
+      REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev)
+      REAL dtls(klev),dqls(klev)
+      REAL tu(klev),qu(klev)
+      REAL hw,sigmaw,wape,fip,gfl
+      REAL omgbdth(klev),dp_omgb(klev)
+      REAL dtKE(klev),dqKE(klev)
+      REAL dtPBL(klev),dqPBL(klev)
+      REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar
+      REAL sigd0,wdens
+
+      REAL RDCP
+
+c      print *, '-> calwake, wake_s ', wake_s(1)
+
+      RDCP=1./3.5
+
+c-----------------------------------------------------------
+      DO 999 i=1,klon   ! a vectoriser
+c----------------------------------------------------------
+
+
+      DO l=1,klev
+        p(l)= pplay(i,l)
+        ph(l)= paprs(i,l)
+        pi(l) = (pplay(i,l)/100000.)**RDCP
+
+        te(l) = t(i,l)
+        qe(l) = q(i,l)
+        omgbe(l) = omgb(i,l)
+
+        dtdwn(l)= dt_dwn(i,l)
+        dqdwn(l)= dq_dwn(i,l)
+        dta(l)= dt_a(i,l)
+        dqa(l)= dq_a(i,l)
+        wdtPBL(l)= wdt_PBL(i,l)
+        wdqPBL(l)= wdq_PBL(i,l)
+        udtPBL(l)= udt_PBL(i,l)
+        udqPBL(l)= udq_PBL(i,l)
+      ENDDO
+      
+      sigd0=sigd(i)
+c      print*, 'sigd0,sigd', sigd0, sigd(i)
+      ph(klev+1)=0.
+
+      ktopw = wake_k(i)
+
+      DO l=1,klev
+        dtw(l) = wake_deltat(i,l)
+        dqw(l) = wake_deltaq(i,l)
+      ENDDO
+
+      DO l=1,klev
+        dtls(l)=dt_wake(i,l)
+        dqls(l)=dq_wake(i,l)
+      ENDDO
+
+      hw = wake_h(i)
+      sigmaw = wake_s(i)
+
+cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+cfkc  on veut le flux de masse au milieu des couches
+
+      DO l=1,klev-1
+        amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
+        amdwn(l)= (M_dwn(i,l+1))
+      ENDDO
+
+c au sommet le flux de masse est nul
+
+      amdwn(klev)=0.5*M_dwn(i,klev)
+c
+      DO l = 1,klev
+        amup(l)=M_up(i,l)
+      ENDDO
+
+      call WAKE_scal(p,ph,pi,dtime,sigd0
+     $                ,te,qe,omgbe
+     $                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     $                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     $                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl
+     $                ,dtls,dqls,ktopw
+     $                ,omgbdth,dp_omgb,wdens
+     $                ,tu,qu
+     $                ,dtKE,dqKE
+     $                ,dtPBL,dqPBL
+     $                ,omg,dp_deltomg,spread
+     $                ,Cstar,d_deltat_gw
+     $                ,d_deltatw,d_deltaqw)
+
+       IF (ktopw .GT. 0) THEN
+         DO l=1,klev
+           wake_deltat(i,l)= dtw(l)
+           wake_deltaq(i,l)= dqw(l)
+           wake_d_deltat_gw(i,l)= d_deltat_gw(l)
+           wake_omgbdth(i,l) = omgbdth(l)
+           wake_dp_omgb(i,l) = dp_omgb(l)
+           wake_dtKE(i,l) = dtKE(l)
+           wake_dqKE(i,l) = dqKE(l)
+ 	   wake_dtPBL(i,l) = dtPBL(l)
+	   wake_dqPBL(i,l) = dqPBL(l)
+           wake_omg(i,l) = omg(l)
+           wake_dp_deltomg(i,l) = dp_deltomg(l)
+           wake_spread(i,l) = spread(l)
+           wake_dth(i,l) = dth(l)
+           dt_wake(i,l) = dtls(l)
+           dq_wake(i,l) = dqls(l)
+           undi_t(i,l) = tu(l)
+           undi_q(i,l) = qu(l)
+           wake_ddeltat(i,l) = d_deltatw(l)
+           wake_ddeltaq(i,l) = d_deltaqw(l)
+         ENDDO
+       ELSE
+         DO l = 1,klev
+           wake_deltat(i,l)= 0.
+           wake_deltaq(i,l)= 0.
+           wake_d_deltat_gw(i,l)= 0.
+           wake_omgbdth(i,l) = 0.
+           wake_dp_omgb(i,l) = 0.
+           wake_dtKE(i,l) = 0.
+           wake_dqKE(i,l) = 0.
+           wake_omg(i,l) = 0.
+           wake_dp_deltomg(i,l) = 0.
+           wake_spread(i,l) = 0.
+           wake_dth(i,l)=0.
+           dt_wake(i,l)=0.
+           dq_wake(i,l)=0.
+           undi_t(i,l)=te(l)
+           undi_q(i,l)=qe(l)
+         ENDDO
+       ENDIF
+
+       wake_h(i)= hw
+       wake_s(i)= sigmaw
+       wake_pe(i)= wape
+       wake_fip(i)= fip
+       wake_gfl(i) = gfl
+       wake_k(i) =ktopw
+       wake_Cstar(i) = Cstar
+       wake_dens(i) = wdens
+c
+ 999  CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/chem.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/chem.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/chem.h	(revision 984)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+      INTEGER idms, iso2, iso4, ih2s, idmso, imsa, ih2o2
+      PARAMETER (idms=1, iso2=2, iso4=3)
+      PARAMETER (ih2s=4, idmso=5, imsa=6, ih2o2=7)
+
+      REAL n_avogadro, masse_s, masse_so4, rho_water, rho_ice
+      PARAMETER (n_avogadro=6.02E23)                  !--molec mol-1
+      PARAMETER (masse_s=32.0)                        !--g mol-1
+      PARAMETER (masse_so4=96.0)                      !--g mol-1
+      PARAMETER (rho_water=1000.0)                    !--kg m-3
+      PARAMETER (rho_ice=500.0)                       !--kg m-3
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/clcdrag.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/clcdrag.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/clcdrag.F90	(revision 984)
@@ -0,0 +1,108 @@
+!
+! $Header$
+!
+      SUBROUTINE clcdrag(klon, knon, nsrf, zxli, &
+                         u, v, t, q, zgeop, &
+                         ts, qsurf, rugos, &
+                         pcfm, pcfh)
+      IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh).   
+!
+! ================================================================= c
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- calcul des cdrags selon Laurent Li
+! u-------input-R- vent zonal au 1er niveau du modele
+! v-------input-R- vent meridien au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+!
+! pcfm---output-R- cdrag pour le moment 
+! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, intent(in), dimension(klon) :: u, v, t, q, zgeop
+      REAL, intent(in), dimension(klon) :: ts, qsurf
+      REAL, intent(in), dimension(klon) :: rugos
+      REAL, intent(out), dimension(klon) :: pcfm, pcfh
+! ================================================================= c
+!
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "indicesol.h"
+!
+! Quelques constantes et options:
+!!$PB      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+      REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+      INTEGER :: i
+      REAL :: zdu2, ztsolv, ztvd, zscf
+      REAL :: zucf, zcr
+      REAL :: friv, frih
+      REAL, dimension(klon) :: zcfm1, zcfm2
+      REAL, dimension(klon) :: zcfh1, zcfh2
+      REAL, dimension(klon) :: zcdn
+      REAL, dimension(klon) :: zri
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+! ================================================================= c
+!
+! Calculer le frottement au sol (Cdrag)
+!
+      DO i = 1, knon
+        zdu2 = max(cepdu2,u(i)**2+v(i)**2)
+        ztsolv = ts(i) * (1.0+RETV*qsurf(i))
+        ztvd = (t(i)+zgeop(i)/RCPD/(1.+RVTMP2*q(i))) &
+             *(1.+RETV*q(i))
+        zri(i) = zgeop(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+        zcdn(i) = (ckap/log(1.+zgeop(i)/(RG*rugos(i))))**2
+!
+!!$        IF (zri(i) .ge. 0.) THEN      ! situation stable
+        IF (zri(i) .gt. 0.) THEN      ! situation stable
+          zri(i) = min(20.,zri(i))
+          IF (.NOT.zxli) THEN
+            zscf = SQRT(1.+cd*ABS(zri(i)))
+            FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1)
+            zcfm1(i) = zcdn(i) * FRIV
+            FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 )
+!!$  PB          zcfh1(i) = zcdn(i) * FRIH
+            zcfh1(i) = 0.8 * zcdn(i) * FRIH
+            pcfm(i) = zcfm1(i)
+            pcfh(i) = zcfh1(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fsta(zri(i))
+            pcfh(i) = zcdn(i)* fsta(zri(i))
+          ENDIF
+        ELSE                          ! situation instable
+          IF (.NOT.zxli) THEN
+            zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
+                 *(1.0+zgeop(i)/(RG*rugos(i)))))
+            zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1)
+!!$PB            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            zcfh2(i) = 0.8 * zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            pcfm(i) = zcfm2(i)
+            pcfh(i) = zcfh2(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fins(zri(i))
+            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) =0.8* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
+        ENDIF
+      END DO
+      RETURN
+      END SUBROUTINE clcdrag
Index: LMDZ4/tags/LF_20080728/libf/phylmd/clesphys.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/clesphys.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/clesphys.h	(revision 984)
@@ -0,0 +1,67 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!..include cles_phys.h
+!
+       LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf 
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
+       REAL co2_ppm, solaire
+       REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12  
+       REAL*8 CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt
+
+!OM ---> correction du bilan d'eau global
+!OM Correction sur precip KE
+       REAL cvl_corr
+!OM Fonte calotte dans bilan eau
+       LOGICAL ok_lic_melt
+
+!IM simulateur ISCCP 
+       INTEGER top_height, overlap
+!IM seuils cdrm, cdrh
+       REAL cdmmax, cdhmax
+!IM param. stabilite s/ terres et en dehors
+       REAL ksta, ksta_ter
+!IM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH
+       LOGICAL ok_kzmin
+!IM, MAFo fmagic, pmagic : parametres - additionnel et multiplicatif - 
+!                          pour regler l albedo sur ocean
+       REAL fmagic, pmagic
+! Hauteur (imposee) du contenu en eau du sol
+           REAL qsol0
+!IM lev_histhf  : niveau sorties 6h
+!IM lev_histday : niveau sorties journalieres
+!IM lev_histmth : niveau sorties mensuelles
+       INTEGER lev_histhf, lev_histday, lev_histmth
+       CHARACTER*4 type_run
+       LOGICAL ok_isccp, ok_regdyn
+       REAL lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+       REAL ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day
+       REAL ecrit_mth, ecrit_tra, ecrit_reg 
+       REAL freq_ISCCP, ecrit_ISCCP
+       INTEGER :: ip_ebil_phy
+       LOGICAL ok_slab_sicOBS
+
+       COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
+     &     ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con       &
+     &     , co2_ppm, solaire, RCO2, RCH4, RN2O, RCFC11, RCFC12         &
+     &     , CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt                     &
+     &     , top_height, overlap, cdmmax, cdhmax, ksta, ksta_ter        &
+     &     , ok_kzmin, fmagic, pmagic                                   &
+     &     , lev_histhf, lev_histday, lev_histmth                       &
+     &     , type_run, ok_isccp, ok_regdyn                              &
+     &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
+     &     , ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day               &
+     &     , ecrit_mth, ecrit_tra, ecrit_reg                            &
+     &     , freq_ISCCP, ecrit_ISCCP, ip_ebil_phy                       &
+     &     , ok_slab_sicOBS, ok_lic_melt, cvl_corr                      &
+     &     , qsol0
+     
+!$OMP THREADPRIVATE(/clesphys/)
+ 
Index: LMDZ4/tags/LF_20080728/libf/phylmd/clift.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/clift.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/clift.F	(revision 984)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+        SUBROUTINE CLIFT (P,T,RR,RS,PLCL,DPLCLDT,DPLCLDQ)
+C***************************************************************
+C*                                                             *
+C* CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
+C*         DERIVATIVES RELATIVE TO T AND R                     *
+C*   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
+C*                                                             *
+C* written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
+C* modified by :                                               *
+C***************************************************************
+C*
+C*Arguments :
+C*
+C* Input :  P = pressure of level from wich lifting is performed
+C*          T = temperature of level P
+C*          RR = vapour mixing ratio at level P
+C*          RS = vapour saturation mixing ratio at level P
+C*
+C* Output : PLCL = lifting condensation level
+C*          DPLCLDT = derivative of PLCL relative to T
+C*          DPLCLDQ = derivative of PLCL relative to R
+C*
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c      CPD = 3.5 * RD
+c      CPV = 4.0 * RV
+c      CL = 4218.0
+c      CI=2090.0
+c      CPVMCL=CL-CPV
+c      CLMCI=CL-CI
+c      EPS=RD/RV
+c      ALV0=2.5008E+06
+c      ALF0=3.34E+05
+c
+c on utilise les constantes thermo du Centre Europeen: (sb)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+c
+c      Bolton formula coefficients :
+      A = 1669.0
+      B = 122.0
+c
+      RH=RR/RS
+      CHI=T/(A-B*RH-T)
+      PLCL=P*(RH**CHI)
+c
+      ALV = ALV0 - CPVMCL*(T-273.15)
+c
+c -- sb: correction:
+c       DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
+      DPLCLDQ = PLCL*CHI*( 1./RR + B*CHI/T/RS*ALOG(RH) )
+c sb --
+c
+      DPLCLDT = PLCL*CHI*((A-B*RH*(1.+ALV/RV/T))/T**2*CHI*ALOG(RH)
+     $                    - ALV/RV/T**2 )
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/climb_hq_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/climb_hq_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/climb_hq_mod.F90	(revision 984)
@@ -0,0 +1,366 @@
+MODULE climb_hq_mod
+!
+! Module to solve the verctical diffusion of "q" and "H"; 
+! specific humidity and potential energi.
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_hq_down, climb_hq_up
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
+  !$OMP THREADPRIVATE(gamaq,gamah)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
+  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
+  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
+  !$OMP THREADPRIVATE(Kcoefhq)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
+       delp, temp, q, dtime, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+    INCLUDE "YOMCST.h"
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petBcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqBcoef
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: dels, local_H
+    REAL, DIMENSION(klon)                    :: psref, delz, pkh
+    INTEGER                                  :: k, i, ierr
+
+! Include
+!****************************************************************************************
+  INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation
+!   
+!****************************************************************************************
+
+    ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
+    
+    ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
+    
+    ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
+    
+    ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
+    
+    ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
+    
+    ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
+    
+    ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
+       
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefhq(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefhq(i,k) = &
+               coefhq(i,k)*RG /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefhq(i,k) = Kcoefhq(i,k) * dtime*RG
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of start value for gama
+    IF (iflag_pbl == 1) THEN
+       gamaq(:,:) = 0.0
+       gamah(:,:) = -1.0e-03
+       gamah(:,2) = -2.5e-03
+    ELSE
+       gamaq(:,:) = 0.0
+       gamah(:,:) = 0.0
+    ENDIF
+    
+!   calculation of gama
+    DO k = 2, klev
+       DO i = 1, knon
+          delz(i)  = RD * (temp(i,k-1)+temp(i,k)) / & 
+               2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+          pkh(i) = (psref(i)/paprs(i,k))**RKAPPA
+          
+          gamaq(i,k) = gamaq(i,k) * delz(i)    
+          gamah(i,k) = gamah(i,k) * delz(i) * RCPD * pkh(i)
+       ENDDO
+    ENDDO
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific humidity, q
+!
+!****************************************************************************************
+    dels(:,:) = delp(:,:)
+    
+    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), dels(:,:), q(:,:), &
+         Ccoef_Q(:,:), Dcoef_Q(:,:))
+
+!****************************************************************************************
+! 5)
+! Calculte the coefficients C and D for potentiel entalpie, H 
+!
+!****************************************************************************************
+    dels(:,:)    = 0.0
+    local_H(:,:) = 0.0
+
+    DO k=1,klev
+       DO i = 1, knon
+          dels(i,k) = (pplay(i,k)/psref(i))**RKAPPA * delp(i,k)               
+          local_H(i,k) = RCPD * temp(i,k) * &
+               (psref(i)/pplay(i,k))**RKAPPA
+       ENDDO
+    ENDDO
+
+
+    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), dels(:,:), local_H(:,:), &
+         Ccoef_H(:,:), Dcoef_H(:,:))
+ 
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    petAcoef(1:knon) = Ccoef_H(1:knon,1)
+    peqAcoef(1:knon) = Ccoef_Q(1:knon,1)
+    petBcoef(1:knon) = Dcoef_H(1:knon,1)
+    peqBcoef(1:knon) = Dcoef_Q(1:knon,1)
+
+  END SUBROUTINE climb_hq_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, gama, dels, X, Ccoef, Dcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is H or Q, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*dels(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*dels(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = dels(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Ccoef(i,1) = (X(i,1)*dels(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Dcoef(i,1) = -1. * RG / buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
+       flx_q1, flx_t1, paprs, pplay, &
+       flux_q, flux_h, d_q, d_t)
+! 
+! This routine calculates the flux and tendency of the specific humidity q and 
+! the potential engergi H. 
+! The quantities q and H are calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_t1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: zx_pkh, zx_pkf
+    REAL, DIMENSION(klon,klev)               :: h_new, q_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+!
+!****************************************************************************************
+    flux_q(:,:) = 0.0
+    flux_h(:,:) = 0.0
+    d_q(:,:)    = 0.0
+    d_t(:,:)    = 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+    DO k = 1, klev
+       DO i = 1, knon
+          zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA
+          zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA
+       END DO
+    END DO
+!****************************************************************************************
+! 2)
+! Calculation of Q and H
+!
+!****************************************************************************************
+
+!- First layer
+    q_new(1:knon,1) = Ccoef_Q(1:knon,1) + Dcoef_Q(1:knon,1)*flx_q1(1:knon)*dtime
+    h_new(1:knon,1) = Ccoef_H(1:knon,1) + Dcoef_H(1:knon,1)*flx_t1(1:knon)*dtime
+    
+!- All the rest layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
+          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for Q and H
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_q(1:knon,1)=flx_q1(1:knon)
+    flux_h(1:knon,1)=flx_t1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
+
+          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) / &
+               zx_pkh(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for Q and H
+!
+!****************************************************************************************
+
+    DO k = 1, klev
+       DO i = 1, knon
+          d_t(i,k) = h_new(i,k)/zx_pkf(i,k)/RCPD - t_old(i,k)
+          d_q(i,k) = q_new(i,k) - q_old(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H)    
+    DEALLOCATE(gamaq, gamah)
+    DEALLOCATE(Kcoefhq)
+
+    
+  END SUBROUTINE climb_hq_up
+!
+!****************************************************************************************
+!
+END MODULE climb_hq_mod
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/climb_wind_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/climb_wind_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/climb_wind_mod.F90	(revision 984)
@@ -0,0 +1,367 @@
+!
+! $Header$
+!
+MODULE climb_wind_mod
+!
+! Module to solve the verctical diffusion of the wind components "u" and "v".
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  SAVE
+  PRIVATE
+  
+  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
+  !$OMP THREADPRIVATE(alf1,alf2)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
+  !$OMP THREADPRIVATE(Kcoefm)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
+  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
+  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
+  LOGICAL                            :: firstcall=.TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+
+  
+  PUBLIC :: climb_wind_down, calcul_wind_flux, climb_wind_up
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_init
+
+    INTEGER             :: ierr
+    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
+
+!****************************************************************************************
+! Allocation of global module variables
+!
+!****************************************************************************************
+
+    ALLOCATE(alf1(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(alf2(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1)
+
+    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1)
+
+    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1)
+
+    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1)
+
+    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1)
+
+    firstcall=.FALSE.
+
+  END SUBROUTINE climb_wind_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old)
+!
+! This routine calculates for the wind components u and v,
+! recursivly the coefficients C and D in equation 
+! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
+!
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)                    :: u1lay, v1lay
+    INTEGER                                  :: k, i
+
+
+!****************************************************************************************
+! Initialize module
+    IF (firstcall) CALL climb_wind_init
+
+!****************************************************************************************
+! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
+!
+!****************************************************************************************
+
+! - Define alpha (alf1 and alf2) 
+    alf1(:) = 1.0
+    alf2(:) = 1.0 - alf1(:)
+
+! - Calculte the wind components for the first layer
+    u1lay(1:knon) = u_old(1:knon,1)*alf1(1:knon) + u_old(1:knon,2)*alf2(1:knon)
+    v1lay(1:knon) = v_old(1:knon,1)*alf1(1:knon) + v_old(1:knon,2)*alf2(1:knon)    
+
+! - Calculate K
+    Kcoefm(:,:) = 0.0
+    DO i = 1, knon
+       Kcoefm(i,1) = coef_in(i,1) * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))* &
+            pplay(i,1)/(RD*temp(i,1)) 
+       Kcoefm(i,1) = Kcoefm(i,1) * dtime*RG
+    END DO
+
+    DO k = 2, klev
+       DO i=1,knon
+          Kcoefm(i,k) = coef_in(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefm(i,k) = Kcoefm(i,k) * dtime*RG
+       END DO
+    END DO
+
+! - Calculate the coefficients C and D, component "u"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         u_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_U(:,:), Dcoef_U(:,:))
+
+! - Calculate the coefficients C and D, component "v"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         v_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_V(:,:), Dcoef_V(:,:))
+
+  END SUBROUTINE climb_wind_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, dels, X, alfa1, alfa2, Ccoef, Dcoef)
+!
+! Find the coefficients C and D in fonction of alfa, K and dels
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+  
+! local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! 
+! Niveau au sommet, k=klev
+!
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+
+       Ccoef(i,klev) = X(i,klev)*dels(i,klev)/buf 
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+    
+! 
+! Niveau  (klev-1) <= k <= 2
+!
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + &
+               Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          
+          Ccoef(i,k) = X(i,k)*dels(i,k) + &
+               Kcoef(i,k+1)*Ccoef(i,k+1)
+          Ccoef(i,k) = Ccoef(i,k)/buf         
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+! 
+! Niveau k=1
+!
+    DO i = 1, knon
+       buf = dels(i,1) + &
+            (alfa1(i) + alfa2(i)*Dcoef(i,2)) * Kcoef(i,1) + &
+            (1.-Dcoef(i,2))*Kcoef(i,2)
+       
+       Ccoef(i,1) = X(i,1)*dels(i,1) + &
+            (Kcoef(i,2)-Kcoef(i,1)*alfa2(i)) * Ccoef(i,2)
+       Ccoef(i,1) = Ccoef(i,1)/buf
+       Dcoef(i,1) = Kcoef(i,1)/buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE calcul_wind_flux(knon, dtime, &
+       flux_u, flux_v)
+
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    REAL, INTENT(IN)                     :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: u0, v0  ! u and v at niveau 0
+    REAL, DIMENSION(klon)                :: u1, v1  ! u and v at niveau 1
+    REAL, DIMENSION(klon)                :: u2, v2  ! u and v at niveau 2
+    
+
+!****************************************************************************************
+! Les vents de surface sont supposes nuls
+!
+!****************************************************************************************
+    u0(:) = 0.0
+    v0(:) = 0.0
+
+!****************************************************************************************
+! On calcule les vents du couhes 1 et 2 recurviement
+!
+!****************************************************************************************
+    DO i = 1, knon
+       u1(i) = Ccoef_U(i,1) + Dcoef_U(i,1)*u0(i)
+       v1(i) = Ccoef_V(i,1) + Dcoef_V(i,1)*v0(i)
+       u2(i) = Ccoef_U(i,2) + Dcoef_U(i,2)*u1(i)
+       v2(i) = Ccoef_V(i,2) + Dcoef_V(i,2)*v1(i)
+    END DO
+
+!****************************************************************************************
+! On calcule le flux
+!
+!****************************************************************************************
+    flux_u(:) = 0.0
+    flux_v(:) = 0.0
+
+    DO i=1,knon
+       flux_u(i) = Kcoefm(i,1)/RG/dtime * (u1(i)*alf1(i) + u2(i)*alf2(i) - u0(i)) 
+       flux_v(i) = Kcoefm(i,1)/RG/dtime * (v1(i)*alf1(i) + v2(i)*alf2(i) - v0(i)) 
+    END DO
+
+  END SUBROUTINE calcul_wind_flux
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, &
+       flx_u_new, flx_v_new, d_u_new, d_v_new)
+!
+! Diffuse the wind components from the surface and up to the top layer. Coefficents
+! C and D are known from before. The values for U and V at surface are supposed to be 
+! zero (this could be modified).
+!
+! u(k) = Cu(k) + Du(k)*u(k-1)
+! v(k) = Cv(k) + Dv(k)*v(k-1)
+! [1 <= k <= klev]
+!
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)              :: u_new, v_new
+    REAL, DIMENSION(klon)                   :: u0, v0
+    INTEGER                                 :: k, i
+    
+!
+!****************************************************************************************
+
+! Niveau 0
+    u0(1:knon) = 0.0
+    v0(1:knon) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       u_new(i,1) = Ccoef_U(i,1) + Dcoef_U(i,1) * u0(i)
+       v_new(i,1) = Ccoef_V(i,1) + Dcoef_V(i,1) * v0(i)
+    END DO
+
+! Niveau 2 jusqu'au sommet klev
+    DO k = 2, klev
+       DO i=1, knon
+          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
+          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul flux
+!
+!== flux_u/v est le flux de moment angulaire (positif vers bas)
+!== dont l'unite est: (kg m/s)/(m**2 s) 
+!
+!****************************************************************************************
+!
+    flx_u_new(:,:) = 0.0
+    flx_v_new(:,:) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       flx_u_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (u_new(i,1)*alf1(i)+u_new(i,2)*alf2(i) - u0(i)) 
+       flx_v_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (v_new(i,1)*alf1(i)+v_new(i,2)*alf2(i) - v0(i)) 
+    END DO
+
+! Niveau 2->klev
+    DO k = 2, klev
+       DO i = 1, knon
+          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (u_new(i,k)-u_new(i,k-1))
+          
+          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (v_new(i,k)-v_new(i,k-1))
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul tendances
+!
+!****************************************************************************************
+    d_u_new(:,:) = 0.0
+    d_v_new(:,:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
+          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
+       END DO
+    END DO
+
+  END SUBROUTINE climb_wind_up
+!
+!****************************************************************************************
+!
+END MODULE climb_wind_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/clouds_gno.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/clouds_gno.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/clouds_gno.F	(revision 984)
@@ -0,0 +1,262 @@
+!
+! $Header$
+!
+C
+C================================================================================
+C
+      SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF)
+      IMPLICIT NONE
+C     
+C--------------------------------------------------------------------------------
+C
+C Inputs:
+C
+C  ND----------: Number of vertical levels
+C  R--------ND-: Domain-averaged mixing ratio of total water 
+C  RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+C  QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+C                with SUBGRID-SCALE condensation processes (here, it is
+C                predicted by the convection scheme)
+C Outputs:
+C
+C  PTCONV-----ND-: Point convectif = TRUE
+C  RATQSC-----ND-: Largeur normalisee de la distribution
+C  CLDF-----ND-: Fraction nuageuse
+C
+C--------------------------------------------------------------------------------
+
+
+      INTEGER klon,ND
+      REAL R(klon,ND),  RS(klon,ND), QSUB(klon,ND)
+      LOGICAL PTCONV(klon,ND)
+      REAL RATQSC(klon,ND)
+      REAL CLDF(klon,ND)
+
+c -- parameters controlling the iteration:
+c --    nmax    : maximum nb of iterations (hopefully never reached)
+c --    epsilon : accuracy of the numerical resolution 
+c --    vmax    : v-value above which we use an asymptotic expression for ERF(v)
+
+      INTEGER nmax
+      PARAMETER ( nmax = 10) 
+      REAL epsilon, vmax0, vmax(klon)
+      PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) 
+
+      REAL min_mu, min_Q
+      PARAMETER ( min_mu =  1.e-12, min_Q=1.e-12 )
+     
+      INTEGER i,K, n, m
+      REAL mu(klon), qsat(klon), delta(klon), beta(klon) 
+      real zu2(klon),zv2(klon)
+      REAL xx(klon), aux(klon), coeff(klon), block(klon)
+      REAL  dist(klon), fprime(klon), det(klon)
+      REAL pi, u(klon), v(klon), erfcu(klon), erfcv(klon)
+      REAL  xx1(klon), xx2(klon)
+      real erf,kkk
+      real sqrtpi,sqrt2,zx1,zx2,exdel
+c lconv = true si le calcul a converge (entre autre si qsub < min_q)
+       LOGICAL lconv(klon)
+
+cym
+      cldf(:,:)=0.0
+      
+      pi = ACOS(-1.)
+      sqrtpi=sqrt(pi)
+      sqrt2=sqrt(2.)
+
+      ptconv=.false.
+      ratqsc=0.
+
+
+      DO 500 K = 1, ND
+
+                                    do i=1,klon ! vector
+      mu(i) = R(i,K)
+      mu(i) = MAX(mu(i),min_mu)
+      qsat(i) = RS(i,K) 
+      qsat(i) = MAX(qsat(i),min_mu)
+      delta(i) = log(mu(i)/qsat(i))
+                                    enddo ! vector
+
+C
+C ***          There is no subgrid-scale condensation;        ***
+C ***   the scheme becomes equivalent to an "all-or-nothing"  *** 
+C ***             large-scale condensation scheme.            ***
+C
+
+C
+C ***     Some condensation is produced at the subgrid-scale       ***
+C ***                                                              ***
+C ***       PDF = generalized log-normal distribution (GNO)        ***
+C ***   (k<0 because a lower bound is considered for the PDF)      ***
+C ***                                                              ***
+C ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+C ***  that the contribution of subgrid-scale processes to         ***
+C ***  the in-cloud water content is equal to QSUB(K)              ***
+C ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+C ***                                                              ***
+C ***    Here, an iterative method is used for this purpose        ***
+C ***    (other numerical methods might be more efficient)         ***
+C ***                                                              ***
+C ***          NB: the "error function" is called ERF              ***
+C ***                 (ERF in double precision)                   ***
+C
+
+c  On commence par eliminer les cas pour lesquels on n'a pas
+c  suffisamment d'eau nuageuse.
+
+                                    do i=1,klon ! vector
+
+      IF ( QSUB(i,K) .lt. min_Q ) THEN
+        ptconv(i,k)=.false.
+        ratqsc(i,k)=0.
+        lconv(i)  = .true.
+
+c   Rien on a deja initialise
+
+      ELSE 
+
+        lconv(i)  = .FALSE. 
+        vmax(i) = vmax0
+
+        beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) )
+
+c --  roots of equation v > vmax:
+
+        det(i) = delta(i) + vmax(i)**2.
+        if (det(i).LE.0.0) vmax(i) = vmax0 + 1.0
+        det(i) = delta(i) + vmax(i)**2.
+
+        if (det(i).LE.0.) then
+          xx(i) = -0.0001
+        else 
+         zx1=-sqrt2*vmax(i)
+         zx2=SQRT(1.0+delta(i)/(vmax(i)**2.))
+         xx1(i)=zx1*(1.0-zx2)
+         xx2(i)=zx1*(1.0+zx2)
+         xx(i) = 1.01 * xx1(i)
+         if ( xx1(i) .GE. 0.0 ) xx(i) = 0.5*xx2(i)
+        endif
+        if (delta(i).LT.0.) xx(i) = -0.5*SQRT(log(2.)) 
+
+      ENDIF
+
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Debut des nmax iterations pour trouver la solution.
+c----------------------------------------------------------------------
+
+      DO n = 1, nmax 
+
+                                    do i=1,klon ! vector
+        if (.not.lconv(i)) then
+
+          u(i) = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
+          v(i) = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
+
+          IF ( v(i) .GT. vmax(i) ) THEN 
+
+            IF (     ABS(u(i))  .GT. vmax(i) 
+     :          .AND.  delta(i) .LT. 0. ) THEN
+
+c -- use asymptotic expression of erf for u and v large:
+c ( -> analytic solution for xx )
+             exdel=beta(i)*EXP(delta(i))
+             aux(i) = 2.0*delta(i)*(1.-exdel)
+     :                       /(1.+exdel)
+             if (aux(i).lt.0.) then
+c                print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i)=0.
+             endif
+             xx(i) = -SQRT(aux(i))
+             block(i) = EXP(-v(i)*v(i)) / v(i) / sqrtpi
+             dist(i) = 0.0
+             fprime(i) = 1.0
+
+            ELSE
+
+c -- erfv -> 1.0, use an asymptotic expression of erfv for v large:
+
+             erfcu(i) = 1.0-ERF(u(i))
+c  !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+             aux(i) = sqrtpi*erfcu(i)*EXP(min(v(i)*v(i),100.))
+             coeff(i) = 1.0 - 1./2./(v(i)**2.) + 3./4./(v(i)**4.)
+             block(i) = coeff(i) * EXP(-v(i)*v(i)) / v(i) / sqrtpi
+             dist(i) = v(i) * aux(i) / coeff(i) - beta(i)
+             fprime(i) = 2.0 / xx(i) * (v(i)**2.)
+     :           * ( coeff(i)*EXP(-delta(i)) - u(i) * aux(i) )
+     :           / coeff(i) / coeff(i)
+            
+            ENDIF ! ABS(u)
+
+          ELSE
+
+c -- general case:
+
+           erfcu(i) = 1.0-ERF(u(i))
+           erfcv(i) = 1.0-ERF(v(i))
+           block(i) = erfcv(i)
+           dist(i) = erfcu(i) / erfcv(i) - beta(i)
+           zu2(i)=u(i)*u(i)
+           zv2(i)=v(i)*v(i)
+           if(zu2(i).gt.20..or. zv2(i).gt.20.) then
+c              print*,'ATTENTION !!! xx(',i,') =', xx(i)
+c           print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+c     .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+c     .CLDF(i,k)
+c              print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2(i)=20.
+              zv2(i)=20.
+             fprime(i) = 0.
+           else
+             fprime(i) = 2. /sqrtpi /xx(i) /erfcv(i)**2.
+     :           * (   erfcv(i)*v(i)*EXP(-zu2(i))
+     :               - erfcu(i)*u(i)*EXP(-zv2(i)) )
+           endif
+          ENDIF ! x
+
+c -- test numerical convergence:
+
+          if (beta(i).lt.1.e-10) then
+              print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i)
+              stop
+          endif
+          if (abs(fprime(i)).lt.1.e-11) then
+              print*,'avant test fprime<.e-11 '
+     s        ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i)
+              print*,'klon,ND,R,RS,QSUB',
+     s        klon,ND,R(i,k),rs(i,k),qsub(i,k)
+              fprime(i)=sign(1.e-11,fprime(i))
+          endif
+
+
+          if ( ABS(dist(i)/beta(i)) .LT. epsilon ) then 
+c           print*,'v-u **2',(v(i)-u(i))**2
+c           print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i,K) = .TRUE. 
+            lconv(i)=.true.
+c  borne pour l'exponentielle
+            ratqsc(i,k)=min(2.*(v(i)-u(i))**2,20.)
+            ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.)
+            CLDF(i,K) = 0.5 * block(i)
+          else
+            xx(i) = xx(i) - dist(i)/fprime(i)
+          endif
+c         print*,'apres test ',i,k,lconv(i)
+
+        endif ! lconv
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Fin des nmax iterations pour trouver la solution.
+        ENDDO ! n
+c----------------------------------------------------------------------
+
+500   CONTINUE  ! K
+
+       RETURN
+       END
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cltrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cltrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cltrac.F	(revision 984)
@@ -0,0 +1,122 @@
+!
+! $Header$
+!
+      SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp,
+     s                  d_tr)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+c            inspire de clvent
+c Objet: diffusion verticale de traceurs avec flux fixe a la surface
+c        ou/et flux du type c-drag
+c======================================================================
+c Arguments:
+c dtime----input-R- intervalle du temps (en second)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c tr-------input-R- la q. de traceurs
+c flux-----input-R- le flux de traceurs a la surface
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c cdrag----input-R- cdrag pour le flux de surface (non active)
+c tr0------input-R- traceurs a la surface ou dans l'ocean (non active)
+c d_tr-----output-R- le changement de tr
+c flux_tr--output-R- flux de tr
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL dtime
+      REAL coef(klon,klev)
+      REAL t(klon,klev), tr(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL d_tr(klon,klev)
+      REAL flux(klon), cdrag(klon), tr0(klon)
+c      REAL flux_tr(klon,klev)
+c======================================================================
+#include "YOMCST.h"
+c======================================================================
+      INTEGER i, k
+      REAL zx_ctr(klon,2:klev)
+      REAL zx_dtr(klon,2:klev)
+      REAL zx_buf(klon)
+      REAL zx_coef(klon,klev)
+      REAL local_tr(klon,klev)
+      REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon)
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+
+c======================================================================
+      DO i = 1, klon
+         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alf2(i) = 1.0 - zx_alf1(i)
+         zx_flux(i) =  -flux(i)*dtime*RG
+c--pour le moment le flux est prescrit
+c--cdrag et zx_coef(1) vaut 0
+         cdrag(i) = 0.0 
+         tr0(i) = 0.0
+         zx_coef(i,1) = cdrag(i)*dtime*RG 
+      ENDDO
+c======================================================================
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k)*dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+         zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+
+     .                  zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+         zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / 
+     .                  zx_buf(i)
+      ENDDO
+c
+      DO k = 3, klev
+      DO i = 1, klon
+         zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
+     .                  + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+         zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)
+     .                  +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+         zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev)
+     .                        +zx_coef(i,klev)*zx_ctr(i,klev) )
+     .                   / ( delp(i,klev) + zx_coef(i,klev)
+     .                       -zx_coef(i,klev)*zx_dtr(i,klev) )
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== flux_tr est le flux de traceur (positif vers bas)
+c      DO i = 1, klon
+c         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+c     .               * (local_tr(i,k)-local_tr(i,k-1))
+c      ENDDO
+c      ENDDO
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         d_tr(i,k) = local_tr(i,k) - tr(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cltracrn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cltracrn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cltracrn.F	(revision 984)
@@ -0,0 +1,294 @@
+!
+! $Header$
+!
+      SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay,
+     e              coef,t,ftsol,pctsrf,
+     e              tr,trs,paprs,pplay,delp,
+     e              masktr,fshtr,hsoltr,tautr,vdeptr,
+     e              lat,
+     s              d_tr,d_trs )
+
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Alex/LMD) date:  fev 99
+c            inspire de clqh + clvent
+c Objet: diffusion verticale de traceurs avec quantite de traceur ds 
+c        le sol ( reservoir de sol de radon ) 
+c        
+c note : pour l'instant le traceur dans le sol et le flux sont
+c        calcules mais ils ne servent que de diagnostiques
+c        seule la tendance sur le traceur est sortie (d_tr)
+c======================================================================
+c Arguments:
+c itr---  -input-R- le type de traceur 1- Rn 2 - Pb
+c dtime----input-R- intervalle du temps (en second)
+c u1lay----input-R- vent u de la premiere couche (m/s)
+c v1lay----input-R- vent v de la premiere couche (m/s)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c ftsol----input-R- temperature du sol (en Kelvin)
+c tr-------input-R- traceurs
+c trs------input-R- traceurs dans le sol
+c masktr---input-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----input-R- Flux surfacique de production dans le sol
+c tautr----input-R- Constante de decroissance du traceur
+c vdeptr---input-R- Vitesse de depot sec dans la couche brownienne
+c hsoltr---input-R- Epaisseur equivalente du reservoir de sol
+c lat-----input-R- latitude en degree
+c d_tr-----output-R- le changement de "tr"
+c d_trs----output-R- le changement de "trs"
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c======================================================================
+      REAL dtime
+      REAL u1lay(klon), v1lay(klon)
+      REAL coef(klon,klev)
+      REAL t(klon,klev), ftsol(klon,nbsrf), pctsrf(klon,nbsrf) 
+      REAL tr(klon,klev), trs(klon)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL masktr(klon) 
+      REAL fshtr(klon) 
+      REAL hsoltr
+      REAL tautr
+      REAL vdeptr
+      REAL lat(klon)   
+      REAL d_tr(klon,klev)
+c======================================================================
+      REAL flux_tr(klon,klev)  ! (diagnostic) flux de traceur
+      REAL d_trs(klon)         ! (diagnostic) traceur ds le sol
+c======================================================================
+      INTEGER i, k, itr, n, l
+      REAL rotrhi(klon)
+      REAL zx_coef(klon,klev)
+      REAL zx_buf(klon)
+      REAL zx_ctr(klon,klev)
+      REAL zx_dtr(klon,klev)
+      REAL zx_trs(klon)
+      REAL zx_a, zx_b
+
+      REAL local_tr(klon,klev)
+      REAL local_trs(klon)
+      REAL zts(klon)
+      REAL zx_alpha1(klon), zx_alpha2(klon)
+c======================================================================
+cAA Pour l'instant les 4 types de surface ne sont pas pris en compte
+cAA On fabrique avec zts un champ de temperature de sol  
+cAA que le pondere par la fraction de nature de sol.
+c 
+c      print*,'PASSAGE DANS CLTRACRN'
+
+      DO i = 1,klon
+            zts(i) = 0. 
+      ENDDO
+c
+      DO n=1,nbsrf
+         DO i = 1,klon
+            zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
+         ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+          rotrhi(i) = RD * zts(i) / hsoltr 
+      END DO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         local_trs(i) = trs(i)
+      ENDDO
+c======================================================================
+cAA   Attention si dans clmain zx_alf1(i) = 1.0 
+cAA   Il doit y avoir coherence (dc la meme chose ici)
+
+      DO i = 1, klon
+cAA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alpha1(i) = 1.0
+         zx_alpha2(i) = 1.0 - zx_alpha1(i)
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_coef(i,1) = coef(i,1)
+     .                 * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))
+     .                 * pplay(i,1)/(RD*t(i,1))
+         zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+      ENDDO
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
+         zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
+         zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
+      ENDDO
+c
+      DO l = klev-1, 2 , -1
+      DO i = 1, klon
+         zx_buf(i) = delp(i,l)+zx_coef(i,l)
+     .              +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
+         zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l)
+     .                   + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
+         zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))
+     .               + masktr(i) * zx_coef(i,1)
+     .               *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
+         zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)
+     .                  + zx_ctr(i,2)
+     .                  *(zx_coef(i,2)
+     .                    - masktr(i) * zx_coef(i,1)
+     .                    *zx_alpha2(i) ) ) / zx_buf(i)
+         zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
+      ENDDO
+c======================================================================
+c Calculer d'abord local_trs nouvelle quantite dans le reservoir
+c de sol
+c
+c-------------------------
+c Au dessus des continents
+c-------------------------
+c Le pb peut se deposer partout : vdeptr = 10-3 m/s
+c Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
+c
+      DO i = 1, klon
+c
+        IF ( NINT(masktr(i)) .EQ. 1 ) THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +fshtr(i)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+cAA: Pour l'instant, pour aller vite, le depot sec est traite
+C comme une decroissance
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c Si on est entre 60N et 70N on divise par 2 l'emanation
+c--------------------------------------------------------
+c
+        IF
+     .  ( (itr.eq.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.)
+     .                      .OR.
+     .     (itr.eq.2.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.) )
+     .  THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +(fshtr(i)/2.)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c----------------------------------------------
+c Au dessus des oceans et aux hautes latitudes
+c----------------------------------------------
+c
+c au dessous de -60S  pas d'emission de radon au dessus 
+c des oceans et des continents
+c---------------------------------------------------------------
+
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c au dessus de 70 N pas d'emission de radon au dessus 
+c des oceans et des continents
+c--------------------------------------------------------------
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c Au dessus des oceans la source est nulle
+c-----------------------------------------
+c
+        IF (itr.eq.1.AND.NINT(masktr(i)).EQ.0) THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+c
+      ENDDO    ! sur le i=1,klon
+c
+c======================================================================
+c==== une fois on a zx_trs, on peut faire l'iteration ========
+c
+      DO i = 1, klon
+         local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        local_tr(i,l)
+     .    = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul du flux de traceur (flux_tr): UA/(m**2 s)
+c
+      DO i = 1, klon
+        flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG
+     .      * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2)
+     .                   -zx_trs(i)) / dtime
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        flux_tr(i,l) = zx_coef(i,l)/RG
+     .       * (local_tr(i,l)-local_tr(i,l-1)) / dtime
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul des tendances du traceur ds le sol et dans l'atmosphere
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_tr(i,l) = local_tr(i,l) - tr(i,l)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         d_trs(i) = local_trs(i) - trs(i)
+      ENDDO
+c======================================================================
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/coef_diff_turb_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/coef_diff_turb_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/coef_diff_turb_mod.F90	(revision 984)
@@ -0,0 +1,645 @@
+!
+! $Header$
+!
+MODULE coef_diff_turb_mod
+!
+! This module contains some procedures for calculation of the coefficients of the
+! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
+! at surface(cdrag)
+!
+  USE dimphy
+  
+  IMPLICIT NONE
+  
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, &
+       ycoefm, ycoefh ,yq2)
+! 
+! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+! atmosphere and coefficients for turbulent diffusion at surface - cdrag
+! (ycoefm(:,1), ycoefh(:,1)).
+!
+!
+! Input arguments
+!****************************************************************************************
+    REAL, INTENT(IN)                           :: dtime
+    INTEGER, INTENT(IN)                        :: nsrf, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
+    REAL, DIMENSION(klon,klev+1)               :: yq2
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                    :: k, i, j
+    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
+    REAL, DIMENSION(klon,klev+1)               :: yzlev, q2diag, ykmm, ykmn, ykmq
+    REAL, DIMENSION(klon)                      :: y_cd_h, y_cd_m
+    REAL, DIMENSION(klon)                      :: yustar
+
+! Include
+!****************************************************************************************
+    INCLUDE "clesphys.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "YOMCST.h"
+
+!****************************************************************************************
+! Start calculation
+! - Initilalize output variables 
+!****************************************************************************************
+
+    ycoefm(:,:) = 0.0
+    ycoefh(:,:) = 0.0
+
+
+!****************************************************************************************    
+! Methode 1 :
+!
+!****************************************************************************************    
+
+    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
+         ksta, ksta_ter, &
+         yts, yrugos, yu, yv, yt, yq, &
+         yqsurf, &
+         ycoefm, ycoefh)
+  
+!****************************************************************************************
+! Methode 2 :
+!
+!****************************************************************************************
+
+    IF (iflag_pbl.EQ.1) THEN
+       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
+            ycoefm0, ycoefh0)
+
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+    ENDIF
+
+!****************************************************************************************
+! IM cf JLD : on seuille ycoefm et ycoefh
+!
+!****************************************************************************************
+    IF (nsrf.EQ.is_oce) THEN
+       DO j=1,knon
+          ycoefm(j,1)=MIN(ycoefm(j,1),cdmmax)
+          ycoefh(j,1)=MIN(ycoefh(j,1),cdhmax)
+       ENDDO
+    ENDIF
+  
+!****************************************************************************************  
+! Calcul d'une diffusion minimale pour les conditions tres stables
+!
+!****************************************************************************************
+    IF (ok_kzmin) THEN
+       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycoefm, &
+            ycoefm0,ycoefh0)
+       
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+       
+    ENDIF
+
+  
+!****************************************************************************************
+! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
+! Methode 3 :
+!****************************************************************************************
+
+    IF (iflag_pbl.GE.3) THEN
+
+       yzlay(1:knon,1)= &
+            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+          DO i = 1, knon
+             yzlay(i,k)= &
+                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
+                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+          END DO
+       END DO
+
+       DO k=1,klev
+          DO i = 1, knon
+             yteta(i,k)= &
+                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
+                  *(1.+0.61*yq(i,k))
+          END DO
+       END DO
+
+       yzlev(1:knon,1)=0.
+       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
+       DO k=2,klev
+          DO i = 1, knon
+             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+          END DO
+       END DO
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
+! bug sur les coefficients de surface :
+!          y_cd_h(1:knon) = ycoefm(1:knon,1)
+!          y_cd_m(1:knon) = ycoefh(1:knon,1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+       y_cd_m(1:knon) = ycoefm(1:knon,1)
+       y_cd_h(1:knon) = ycoefh(1:knon,1)
+       
+       CALL ustarhb(knon,yu,yv,y_cd_m, yustar)
+     
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*) 'USTAR = ',yustar
+       ENDIF
+         
+!   iflag_pbl peut etre utilise comme longuer de melange
+       IF (iflag_pbl.GE.11) THEN
+          CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,q2diag,ykmm,ykmn,yustar, &
+               iflag_pbl)
+       ELSE
+          CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,ykmm,ykmn,ykmq,yustar, &
+               iflag_pbl)
+       ENDIF
+       
+       ycoefm(1:knon,1)=y_cd_m(1:knon)
+       ycoefh(1:knon,1)=y_cd_h(1:knon)
+       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
+       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
+                
+    ENDIF !(iflag_pbl.ge.3)
+
+  END SUBROUTINE coef_diff_turb
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
+       ksta, ksta_ter, &
+       ts, rugos, &
+       u,v,t,q, &
+       qsurf, &
+       pcfm, pcfh)
+    
+!======================================================================
+! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+!           (une version strictement identique a l'ancien modele)
+! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+!        coefficients d'echange turbulent dans l'atmosphere.
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pregssion a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! ts-------input-R- temperature du sol (en Kelvin)
+! rugos----input-R- longeur de rugosite (en m)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOMCST.h"
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                      :: knon, nsrf
+    REAL, DIMENSION(klon), INTENT(IN)        :: ts
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
+
+
+! Local variables
+
+! numero de couche du sommet de la couche limite
+    INTEGER, DIMENSION(klon)    :: itop
+!
+! Quelques constantes et options:
+!
+    REAL cepdu2, ckap, cb, cc, cd, clam
+    PARAMETER (cepdu2 =(0.1)**2)
+    PARAMETER (CKAP=0.4)
+    PARAMETER (cb=5.0)
+    PARAMETER (cc=5.0)
+    PARAMETER (cd=5.0)
+    PARAMETER (clam=160.0)
+    REAL ratqs ! largeur de distribution de vapeur d'eau
+    PARAMETER (ratqs=0.05)
+    LOGICAL richum ! utilise le nombre de Richardson humide
+    PARAMETER (richum=.TRUE.)
+    REAL ric ! nombre de Richardson critique
+    PARAMETER(ric=0.4)
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable ! diffusion minimale (situation stable)
+    ! GKtest
+    ! PARAMETER (kstable=1.0e-10)
+    REAL ksta, ksta_ter
+!IM: 261103     REAL kstable_ter, kstable_sinon
+!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
+!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
+!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
+!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
+    ! fin GKtest
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    INTEGER isommet ! le sommet de la couche limite
+    LOGICAL tvirtu ! calculer Ri d'une maniere plus performante
+    PARAMETER (tvirtu=.TRUE.)
+    LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
+    PARAMETER (opt_ec=.FALSE.)
+
+!
+! Variables locales:
+
+    INTEGER i, k !IM 120704
+    REAL zgeop(klon,klev)
+    REAL zmgeom(klon)
+    REAL zri(klon)
+    REAL zl2(klon)
+    
+    REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon)
+    REAL pcfm1(klon), pcfh1(klon)
+
+    REAL zdphi, zdu2, ztvd, ztvu, zcdn
+    REAL zscf
+    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+    REAL t_coup
+    PARAMETER (t_coup=273.15)
+!IM
+    LOGICAL check
+    PARAMETER (check=.FALSE.)
+!
+! contre-gradient pour la chaleur sensible: Kelvin/metre
+    REAL gamt(2:klev)
+    REAL qsurf(klon) 
+
+    LOGICAL, SAVE :: appel1er
+    !$OMP THREADPRIVATE(appel1er)
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+    REAL fsta, fins, x
+    LOGICAL zxli ! utiliser un jeu de fonctions simples
+    PARAMETER (zxli=.FALSE.)
+
+    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+    fins(x) = SQRT(1.0-18.0*x)
+
+    DATA appel1er /.TRUE./
+
+
+    isommet=klev
+      
+    IF (appel1er) THEN
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
+          WRITE(lunout,*)'coefkz, richum:', richum
+          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
+          WRITE(lunout,*)'coefkz, isommet:', isommet
+          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
+          appel1er = .FALSE.
+       ENDIF
+    ENDIF
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+    DO i = 1, knon
+       itop(i) = 0
+    ENDDO
+    
+!
+! Prescrire la valeur de contre-gradient
+!
+    IF (iflag_pbl.EQ.1) THEN
+       DO k = 3, klev
+          gamt(k) = -1.0E-03
+       ENDDO
+       gamt(2) = -2.5E-03
+    ELSE
+       DO k = 2, klev
+          gamt(k) = 0.0
+       ENDDO
+    ENDIF
+!IM cf JLD/ GKtest
+    IF ( nsrf .NE. is_oce ) THEN
+!IM 261103     kstable = kstable_ter
+       kstable = ksta_ter
+    ELSE
+!IM 261103     kstable = kstable_sinon
+       kstable = ksta
+    ENDIF
+!IM cf JLD/ GKtest fin
+
+!
+! Calculer les geopotentiels de chaque couche
+!
+    DO i = 1, knon
+       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+            * (paprs(i,1)-pplay(i,1))
+    ENDDO
+    DO k = 2, klev
+       DO i = 1, knon
+          zgeop(i,k) = zgeop(i,k-1) &
+               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+               * (pplay(i,k-1)-pplay(i,k))
+       ENDDO
+    ENDDO
+
+!
+! Calculer le frottement au sol (Cdrag)
+!
+    DO i = 1, knon
+       u1(i) = u(i,1)
+       v1(i) = v(i,1)
+       t1(i) = t(i,1)
+       q1(i) = q(i,1)
+       z1(i) = zgeop(i,1)
+    ENDDO
+
+    CALL clcdrag(klon, knon, nsrf, zxli, &
+         u1, v1, t1, q1, z1, &
+         ts, qsurf, rugos, &
+         pcfm1, pcfh1) 
+!IM               ts, qsurf, rugos,
+
+    DO i = 1, knon
+       pcfm(i,1)=pcfm1(i)
+       pcfh(i,1)=pcfh1(i)
+    ENDDO
+!
+! Calculer les coefficients turbulents dans l'atmosphere
+!
+    DO i = 1, knon
+       itop(i) = isommet
+    ENDDO
+
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
+               +(v(i,k)-v(i,k-1))**2)
+          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+          zdphi =zmgeom(i) / 2.0
+          zt = (t(i,k)+t(i,k-1)) * 0.5
+          zq = (q(i,k)+q(i,k-1)) * 0.5
+
+!
+! Calculer Qs et dQs/dT:
+!
+          IF (thermcep) THEN
+             zdelta = MAX(0.,SIGN(1.,RTT-zt))
+             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
+                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+             zqs = MIN(0.5,zqs)
+             zcor = 1./(1.-RETV*zqs)
+             zqs = zqs*zcor
+             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+          ELSE
+             IF (zt .LT. t_coup) THEN
+                zqs = qsats(zt) / pplay(i,k)
+                zdqs = dqsats(zt,zqs)
+             ELSE
+                zqs = qsatl(zt) / pplay(i,k)
+                zdqs = dqsatl(zt,zqs)
+             ENDIF
+          ENDIF
+!
+!           calculer la fraction nuageuse (processus humide):
+!
+          zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+          zfr = MAX(0.0,MIN(1.0,zfr))
+          IF (.NOT.richum) zfr = 0.0
+!
+!           calculer le nombre de Richardson:
+!
+          IF (tvirtu) THEN
+             ztvd =( t(i,k) &
+                  + zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k))
+             ztvu =( t(i,k-1) &
+                  - zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k-1))
+             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+             zri(i) = zri(i) &
+                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(ztvd+ztvu))
+
+          ELSE ! calcul de Ridchardson compatible LMD5
+
+             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
+                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
+                  *(pplay(i,k)-pplay(i,k-1)) &
+                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+             zri(i) = zri(i) + &
+                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+          ENDIF
+!
+!           finalement, les coefficients d'echange sont obtenus:
+!
+          zcdn=SQRT(zdu2) / zmgeom(i) * RG
+
+          IF (opt_ec) THEN
+             z2geomf=zgeop(i,k-1)+zgeop(i,k)
+             zalm2=(0.5*ckap/RG*z2geomf &
+                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
+             zalh2=(0.5*ckap/rg*z2geomf &
+                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+             IF (zri(i).LT.0.0) THEN  ! situation instable
+                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
+                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+                zscf = SQRT(-zri(i)*zscf)
+                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+             ELSE ! situation stable
+                zscf=SQRT(1.+cd*zri(i))
+                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+             ENDIF
+          ELSE
+             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
+                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+             pcfm(i,k)= zl2(i)* pcfm(i,k)
+             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Au-dela du sommet, pas de diffusion turbulente:
+!
+    DO i = 1, knon
+       IF (itop(i)+1 .LE. klev) THEN
+          DO k = itop(i)+1, klev
+             pcfh(i,k) = 0.0
+             pcfm(i,k) = 0.0
+          ENDDO
+       ENDIF
+    ENDDO
+      
+  END SUBROUTINE coefkz
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
+       pcfm, pcfh)
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: knon, nsrf
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
+    
+    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
+!
+! Quelques constantes et options:
+!
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable
+    PARAMETER (kstable=0.002)
+!    PARAMETER (kstable=0.001)
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    REAL seuil ! au-dela l'inversion est consideree trop faible
+    PARAMETER (seuil=-0.02)
+!    PARAMETER (seuil=-0.04)
+!    PARAMETER (seuil=-0.06)
+!    PARAMETER (seuil=-0.09)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(knon)
+    REAL zl2(knon)
+    REAL zdthmin(knon), zdthdp
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+
+!
+! Chercher la zone d'inversion forte
+!
+    DO i = 1, knon
+       invb(i) = klev
+       zdthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, knon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.zdthmin(i) ) THEN
+             zdthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Introduire une diffusion:
+!
+    IF ( nsrf.EQ.is_oce ) THEN
+       DO k = 2, klev
+          DO i = 1, knon
+!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+      !IM cf JLD/ GKtest TERkz2
+      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
+      ! fin GKtest
+
+
+! s'il n'y a pas d'inversion ou si l'inversion est trop faible
+!          IF ( (nsrf.EQ.is_oce) .AND. &
+             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
+                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
+                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
+                pcfm(i,k)= zl2(i)* kstable
+                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE coefkz2
+!
+!****************************************************************************************
+!
+END MODULE coef_diff_turb_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/coefcdrag.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/coefcdrag.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/coefcdrag.F90	(revision 984)
@@ -0,0 +1,147 @@
+!
+! $Header$
+!
+!
+!
+!
+      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
+                            speed, t, q, zgeop, psol, &
+                            ts, qsurf, rugos, okri, ri1, &
+                            cdram, cdrah, cdran, zri1, pref)
+      IMPLICIT none
+!-------------------------------------------------------------------------
+! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
+!         sensible et latente (cdrah), du cdrag neutre (cdran), 
+!         du nombre de Richardson entre la surface et le niveau de reference 
+!         (zri1) et de la pression au niveau de reference (pref).    
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! psol----input-R- pression au sol 
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
+!
+! cdram--output-R- cdrag pour le moment
+! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
+! cdran--output-R- cdrag neutre
+! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
+! pref---output-R- pression au niveau zgeop/RG
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli 
+      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
+      LOGICAL, intent(in) :: okri    
+!
+      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
+!-------------------------------------------------------------------------
+!
+      include "YOMCST.h"
+      include "YOETHF.h"
+      include "indicesol.h"
+! Quelques constantes :
+      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0
+!
+! Variables locales :
+      INTEGER :: i
+      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
+      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
+      REAL, dimension(klon) :: zcfm1, zcfh1
+      REAL, dimension(klon) :: zcfm2, zcfh2
+      REAL, dimension(klon) :: trm0, trm1
+!-------------------------------------------------------------------------
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+!-------------------------------------------------------------------------
+!
+      DO i = 1, knon
+!
+       zdphi(i) = zgeop(i)
+       zdu2(i) = speed(i)**2
+       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
+                 (1.+ RETV * max(q(i),0.0))))
+       ztsolv(i) = ts(i)
+       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
+       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
+       trm1(i) = 1. + RETV * max(q(i),0.0)
+       ztsolv(i) = ztsolv(i) * trm0(i)
+       ztvd(i) = ztvd(i) * trm1(i)
+       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
+!
+! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
+!
+!IM +++
+       IF(1.EQ.0) THEN
+       IF (okri) THEN
+         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
+           zri1(i) = ri1(i)
+         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
+           zri1(i) = ri1(i)
+         ENDIF 
+       ENDIF
+       ENDIF
+!IM ---
+! 
+       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
+
+       IF (zri1(i) .ge. 0.) THEN 
+!
+! situation stable : pour eviter les inconsistances dans les cas 
+! tres stables on limite zri1 a 20. cf Hess et al. (1995)
+!
+         zri1(i) = min(20.,zri1(i))
+!
+         IF (.NOT.zxli) THEN
+           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
+           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1)
+           zcfm1(i) = cdran(i) * friv(i)
+           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 )
+           zcfh1(i) = cdran(i) * frih(i)
+           cdram(i) = zcfm1(i)
+           cdrah(i) = zcfh1(i)
+         ELSE
+           cdram(i) = cdran(i)* fsta(zri1(i))
+           cdrah(i) = cdran(i)* fsta(zri1(i))
+         ENDIF
+!
+       ELSE
+! 
+! situation instable
+!
+         IF (.NOT.zxli) THEN
+           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
+                 *(1.0+zdphi(i)/(RG*rugos(i)))))
+           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1)
+           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
+           cdram(i) = zcfm2(i)
+           cdrah(i) = zcfh2(i)
+         ELSE
+           cdram(i) = cdran(i)* fins(zri1(i))
+           cdrah(i) = cdran(i)* fins(zri1(i))
+         ENDIF
+!
+! cdrah sur l'ocean cf. Miller et al. (1992)
+!
+         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
+               **(1./3.)
+         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
+                  **(1./1.25)
+       ENDIF
+!
+      END DO
+      RETURN 
+      END SUBROUTINE coefcdrag
Index: LMDZ4/tags/LF_20080728/libf/phylmd/coefkzmin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/coefkzmin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/coefkzmin.F	(revision 984)
@@ -0,0 +1,136 @@
+!
+! $Header$
+!
+       SUBROUTINE coefkzmin(ngrid,ypaprs,ypplay,yu,yv,yt,yq,ycoefm
+     .   ,km,kn)
+c      SUBROUTINE coefkzmin(ngrid,zlev,teta,ustar,km,kn)
+      USE dimphy
+      IMPLICIT NONE
+
+      include "YOMCST.h"
+
+c.......................................................................
+c  Entrees modifies en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+
+      REAL  ycoefm(klon,klev)
+
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      REAL ypaprs(klon,klev+1), ypplay(klon,klev)
+      REAL yustar(klon)
+      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
+
+      integer i
+
+c.......................................................................
+c
+c  En entree :
+c  -----------
+c
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c ustar : u*
+c
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c
+c  en sortier :
+c  ------------
+c
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL teta(klon,klev)
+
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer ngrid
+
+
+      integer nlay,nlev
+      integer ig,k
+
+      real,parameter :: kap=0.4
+
+      nlay=klev
+      nlev=klev+1
+c.......................................................................
+c  en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+c  Debut de la partie qui doit etre unclue a terme dans clmain.
+c
+         do i=1,ngrid
+            yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1)))
+     .                *(ypaprs(i,1)-ypplay(i,1))/RG
+         enddo
+         do k=2,klev
+            do i=1,ngrid
+               yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k))
+     s                /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+            enddo
+         enddo
+         do k=1,klev
+            do i=1,ngrid
+cATTENTION:on passe la temperature potentielle virt. pour le calcul de K
+             yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa
+     s          *(1.+0.61*yq(i,k))
+            enddo
+         enddo
+         do i=1,ngrid
+            yzlev(i,1)=0.
+            yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1)
+         enddo
+         do k=2,klev
+            do i=1,ngrid
+               yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+            enddo
+         enddo
+
+
+cIM cf FH   yustar(:) =SQRT(ycoefm(:,1)*(yu(:,1)*yu(:,1)+yv(:,1)*yv(:,1)))
+      yustar(1:ngrid) =SQRT(ycoefm(1:ngrid,1)*
+     $       (yu(1:ngrid,1)*yu(1:ngrid,1)+yv(1:ngrid,1)*yv(1:ngrid,1)))
+
+c  Fin de la partie qui doit etre unclue a terme dans clmain.
+
+Cette routine est ecrite pour avoir en entree ustar, teta et zlev
+c  Ici, on a inclut le calcul de ces trois variables dans la routine
+c  coefkzmin en attendant une nouvelle version de la couche limite
+c  ou ces variables seront disponibles.
+
+c Debut de la routine coefkzmin proprement dite.
+
+      ustar=yustar
+      teta=yteta
+      zlev=yzlev
+
+      do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+      enddo
+      
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=0. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            kn(ig,k)=kmin
+            km(ig,k)=kmin
+         enddo
+      enddo
+
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/comgeomphy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/comgeomphy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/comgeomphy.F90	(revision 984)
@@ -0,0 +1,23 @@
+module comgeomphy
+   real,save,allocatable :: airephy(:)
+   real,save,allocatable :: cuphy(:)
+   real,save,allocatable :: cvphy(:)
+   real,save,allocatable :: rlatd(:)
+   real,save,allocatable :: rlond(:)
+!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond)
+contains
+  
+  subroutine InitComgeomphy
+  USE mod_phys_lmdz_para
+  implicit none
+    
+ 
+    allocate(airephy(klon_omp))
+    allocate(cuphy(klon_omp))
+    allocate(cvphy(klon_omp))
+    allocate(rlatd(klon_omp))
+    allocate(rlond(klon_omp))
+
+  end subroutine InitComgeomphy
+  
+end module comgeomphy
Index: LMDZ4/tags/LF_20080728/libf/phylmd/comgeomphy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/comgeomphy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/comgeomphy.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+c
+c
+c Common de passage de la geometrie de la dynamique a la physique
+      real airephy(klon),cuphy(klon),cvphy(klon)
+      REAL rlatd(klon), rlond(klon)
+      common/comgeomphy/airephy,cuphy,cvphy,rlatd, rlond
Index: LMDZ4/tags/LF_20080728/libf/phylmd/compbl.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/compbl.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/compbl.h	(revision 984)
@@ -0,0 +1,6 @@
+      !
+      ! $Header$
+      !
+      integer iflag_pbl
+      common/compbl/iflag_pbl
+!$OMP THREADPRIVATE(/compbl/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/comsoil.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/comsoil.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/comsoil.h	(revision 984)
@@ -0,0 +1,6 @@
+!
+! $Header$
+!
+
+      common /comsoil/inertie_sol,inertie_sno,inertie_ice
+      real inertie_sol,inertie_sno,inertie_ice
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conccm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conccm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conccm.F	(revision 984)
@@ -0,0 +1,835 @@
+!
+! $Header$
+!
+      SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q,
+     s                   d_t, d_q, rain, snow, kbascm, ktopcm)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996
+c Objet: Schema simple (avec flux de masse) pour la convection 
+c        (schema standard du modele NCAR CCM2)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Entree:
+      REAL dtime              ! pas d'integration
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (g/g)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c Sortie:
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation vapeur
+      REAL rain(klon)         ! pluie (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER kbascm(klon)    ! niveau du bas de convection
+      INTEGER ktopcm(klon)    ! niveau du haut de convection
+c
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pres(klon,klev)
+      REAL dp(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL cmfprs(klon)
+      REAL cmfprt(klon)
+      INTEGER ntop(klon)
+      INTEGER nbas(klon)
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql_bis(klon,klev)
+      REAL rneb_bis(klon,klev)
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kbascm(i) = 0
+         ktopcm(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         pres(i,k) = pplay(i,klev-k+1)
+         dp(i,k) = paprs(i,klev+1-k)-paprs(i,klev+1-k+1)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                      * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgeom(i,klev+1-k) = zgeom(i,klev+1-k+1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+      CALL cmfmca(dtime, pres, dp, zgeom, pt, pq,
+     $                  cmfprt, cmfprs, ntop, nbas)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = pq(i,k) - q(i,klev+1-k) 
+         d_t(i,klev+1-k) = pt(i,k) - t(i,klev+1-k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         rain(i) = cmfprt(i) * rhoh2o
+         snow(i) = cmfprs(i) * rhoh2o
+         kbascm(i) = klev+1 - nbas(i)
+         ktopcm(i) = klev+1 - ntop(i)
+      ENDDO
+c
+      IF (usekuo) THEN
+      CALL conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s            d_t_bis, d_q_bis, d_ql_bis, rneb_bis,
+     s            rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         kbascm(i) = MIN(kbascm(i),ibas_bis(i))
+         ktopcm(i) = MAX(ktopcm(i),itop_bis(i))
+      ENDDO
+      DO k = 1, klev ! eau liquide convective est
+      DO i = 1, klon ! dispersee dans l'air
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql_bis(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE cmfmca(deltat, p, dp, gz,
+     $                  tb, shb,
+     $                  cmfprt, cmfprs, cnt, cnb)
+      USE dimphy
+      IMPLICIT none
+C-----------------------------------------------------------------------
+C Moist convective mass flux procedure:
+C If stratification is unstable to nonentraining parcel ascent,
+C complete an adjustment making use of a simple cloud model
+C 
+C Code generalized to allow specification of parcel ("updraft")
+C properties, as well as convective transport of an arbitrary
+C number of passive constituents (see cmrb array).
+C----------------------------Code History-------------------------------
+C Original version:  J. J. Hack, March 22, 1990
+C Standardized:      J. Rosinski, June 1992
+C Reviewed:          J. Hack, G. Taylor, August 1992
+c Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994,
+c                    J. Geophys. Res. vol 99, D3, 5551-5568). J'ai
+c                    introduit les constantes et les fonctions thermo-
+c                    dynamiques du Centre Europeen. J'ai elimine le
+c                    re-indicage du code en esperant que cela pourra
+c                    simplifier la lecture et la comprehension.
+C-----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      INTEGER pcnst ! nombre de traceurs passifs
+      PARAMETER (pcnst=1)
+C------------------------------Arguments--------------------------------
+C Input arguments
+C
+      REAL deltat                 ! time step (seconds)
+      REAL p(klon,klev)           ! pressure
+      REAL dp(klon,klev)          ! delta-p
+      REAL gz(klon,klev)          ! geopotential (a partir du sol)
+c
+      REAL thtap(klon)            ! PBL perturbation theta
+      REAL shp(klon)              ! PBL perturbation specific humidity 
+      REAL pblh(klon)             ! PBL height (provided by PBL routine)
+      REAL cmrp(klon,pcnst)       ! constituent perturbations in PBL
+c
+c Updated arguments:
+c
+      REAL tb(klon,klev)         ! temperature (t bar)
+      REAL shb(klon,klev)        ! specific humidity (sh bar)
+      REAL cmrb(klon,klev,pcnst) ! constituent mixing ratios (cmr bar)
+C
+C Output arguments
+C
+      REAL cmfdt(klon,klev)    ! dT/dt due to moist convection
+      REAL cmfdq(klon,klev)    ! dq/dt due to moist convection
+      REAL cmfmc(klon,klev )   ! moist convection cloud mass flux
+      REAL cmfdqr(klon,klev)   ! dq/dt due to convective rainout 
+      REAL cmfsl(klon,klev )   ! convective lw static energy flux
+      REAL cmflq(klon,klev )   ! convective total water flux
+      REAL cmfprt(klon)        ! convective precipitation rate
+      REAL cmfprs(klon)        ! convective snowfall rate
+      REAL qc(klon,klev)       ! dq/dt due to rainout terms
+      INTEGER cnt(klon)        ! top level of convective activity   
+      INTEGER cnb(klon)        ! bottom level of convective activity
+C------------------------------Parameters-------------------------------
+      REAL c0         ! rain water autoconversion coefficient
+      PARAMETER (c0=1.0e-4)
+      REAL dzmin       ! minimum convective depth for precipitation
+      PARAMETER (dzmin=0.0)
+      REAL betamn      ! minimum overshoot parameter
+      PARAMETER (betamn=0.10)
+      REAL cmftau      ! characteristic adjustment time scale
+      PARAMETER (cmftau=3600.)
+      INTEGER limcnv   ! top interface level limit for convection
+      PARAMETER (limcnv=1)
+      REAL tpmax       ! maximum acceptable t perturbation (degrees C)
+      PARAMETER (tpmax=1.50)
+      REAL shpmax      ! maximum acceptable q perturbation (g/g)
+      PARAMETER (shpmax=1.50e-3)
+      REAL tiny        ! arbitrary small num used in transport estimates
+      PARAMETER (tiny=1.0e-36)
+      REAL eps         ! convergence criteria (machine dependent)
+      PARAMETER (eps=1.0e-13)
+      REAL tmelt       ! freezing point of water(req'd for rain vs snow)
+      PARAMETER (tmelt=273.15)
+      REAL ssfac ! supersaturation bound (detrained air)
+      PARAMETER (ssfac=1.001)
+C
+C---------------------------Local workspace-----------------------------
+      REAL gam(klon,klev)     ! L/cp (d(qsat)/dT)
+      REAL sb(klon,klev)      ! dry static energy (s bar)
+      REAL hb(klon,klev)      ! moist static energy (h bar)
+      REAL shbs(klon,klev)    ! sat. specific humidity (sh bar star)
+      REAL hbs(klon,klev)     ! sat. moist static energy (h bar star)
+      REAL shbh(klon,klev+1)  ! specific humidity on interfaces
+      REAL sbh(klon,klev+1)   ! s bar on interfaces
+      REAL hbh(klon,klev+1)   ! h bar on interfaces
+      REAL cmrh(klon,klev+1)  ! interface constituent mixing ratio 
+      REAL prec(klon)         ! instantaneous total precipitation
+      REAL dzcld(klon)        ! depth of convective layer (m)
+      REAL beta(klon)         ! overshoot parameter (fraction)
+      REAL betamx             ! local maximum on overshoot
+      REAL eta(klon)          ! convective mass flux (kg/m^2 s)
+      REAL etagdt             ! eta*grav*deltat
+      REAL cldwtr(klon)       ! cloud water (mass)
+      REAL rnwtr(klon)        ! rain water  (mass)
+      REAL sc  (klon)         ! dry static energy   ("in-cloud")
+      REAL shc (klon)         ! specific humidity   ("in-cloud")
+      REAL hc  (klon)         ! moist static energy ("in-cloud")
+      REAL cmrc(klon)         ! constituent mix rat ("in-cloud")
+      REAL dq1(klon)          ! shb  convective change (lower lvl)
+      REAL dq2(klon)          ! shb  convective change (mid level)
+      REAL dq3(klon)          ! shb  convective change (upper lvl)
+      REAL ds1(klon)          ! sb   convective change (lower lvl)
+      REAL ds2(klon)          ! sb   convective change (mid level)
+      REAL ds3(klon)          ! sb   convective change (upper lvl)
+      REAL dcmr1(klon)        ! cmrb convective change (lower lvl)
+      REAL dcmr2(klon)        ! cmrb convective change (mid level)
+      REAL dcmr3(klon)        ! cmrb convective change (upper lvl)
+      REAL flotab(klon)       ! hc - hbs (mesure d'instabilite)
+      LOGICAL ldcum(klon)     ! .true. si la convection existe
+      LOGICAL etagt0          ! true if eta > 0.0
+      REAL dt                 ! current 2 delta-t (model time step)
+      REAL cats     ! modified characteristic adj. time
+      REAL rdt      ! 1./dt
+      REAL qprime   ! modified specific humidity pert.
+      REAL tprime   ! modified thermal perturbation
+      REAL pblhgt   ! bounded pbl height (max[pblh,1m])
+      REAL fac1     ! intermediate scratch variable
+      REAL shprme   ! intermediate specific humidity pert.
+      REAL qsattp   ! saturation mixing ratio for 
+C                   !  thermally perturbed PBL parcels 
+      REAL dz       ! local layer depth
+      REAL b1       ! bouyancy measure in detrainment lvl
+      REAL b2       ! bouyancy measure in condensation lvl
+      REAL g     ! bounded vertical gradient of hb
+      REAL tmass ! total mass available for convective exchange
+      REAL denom ! intermediate scratch variable
+      REAL qtest1! used in negative q test (middle lvl) 
+      REAL qtest2! used in negative q test (lower lvl) 
+      REAL fslkp ! flux lw static energy (bot interface)
+      REAL fslkm ! flux lw static energy (top interface)
+      REAL fqlkp ! flux total water (bottom interface)
+      REAL fqlkm ! flux total water (top interface)
+      REAL botflx! bottom constituent mixing ratio flux
+      REAL topflx! top constituent mixing ratio flux
+      REAL efac1 ! ratio cmrb to convectively induced change (bot lvl)
+      REAL efac2 ! ratio cmrb to convectively induced change (mid lvl)
+      REAL efac3 ! ratio cmrb to convectively induced change (top lvl)
+c
+      INTEGER i,k  ! indices horizontal et vertical
+      INTEGER km1  ! k-1 (index offset)
+      INTEGER kp1  ! k+1 (index offset)
+      INTEGER m    ! constituent index
+      INTEGER ktp  ! temporary index used to track top 
+      INTEGER is   ! nombre de points a ajuster
+C
+      REAL tmp1, tmp2, tmp3, tmp4
+      REAL zx_t, zx_p, zx_q, zx_qs, zx_gam
+      REAL zcor, zdelta, zcvm5
+C
+      REAL qhalf, sh1, sh2, shbs1, shbs2
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      qhalf(sh1,sh2,shbs1,shbs2) = MIN(MAX(sh1,sh2),
+     $                            (shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2))
+C
+C-----------------------------------------------------------------------
+c pas de traceur pour l'instant
+      DO m = 1, pcnst
+      DO k = 1, klev
+      DO i = 1, klon
+         cmrb(i,k,m) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+c
+c Les perturbations de la couche limite sont zero pour l'instant
+c
+      DO m = 1, pcnst
+      DO i = 1, klon
+         cmrp(i,m) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         thtap(i) = 0.0
+         shp(i) = 0.0
+         pblh(i) = 1.0
+      ENDDO
+C
+C Ensure that characteristic adjustment time scale (cmftau) assumed
+C in estimate of eta isn't smaller than model time scale (deltat)
+C
+      dt   = deltat
+      cats = MAX(dt,cmftau)
+      rdt  = 1.0/dt
+C
+C Compute sb,hb,shbs,hbs
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = tb(i,k)
+         zx_p = p(i,k)
+         zx_q = shb(i,k)
+           zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+           zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+           zx_qs=MIN(0.5,zx_qs)
+           zcor=1./(1.-retv*zx_qs)
+           zx_qs=zx_qs*zcor
+           zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+         shbs(i,k) = zx_qs
+         gam(i,k) = zx_gam
+      ENDDO
+      ENDDO
+C
+      DO k=limcnv,klev
+         DO i=1,klon
+            sb (i,k) = RCPD*tb(i,k) + gz(i,k)
+            hb (i,k) = sb(i,k) + RLVTT*shb(i,k)
+            hbs(i,k) = sb(i,k) + RLVTT*shbs(i,k)
+         ENDDO
+      ENDDO
+C
+C Compute sbh, shbh
+C
+      DO k=limcnv+1,klev
+         km1 = k - 1
+         DO i=1,klon
+            sbh (i,k) =0.5*(sb(i,km1) + sb(i,k))
+            shbh(i,k) =qhalf(shb(i,km1),shb(i,k),shbs(i,km1),shbs(i,k))
+            hbh (i,k) =sbh(i,k) + RLVTT*shbh(i,k)
+         ENDDO
+      ENDDO
+C
+C Specify properties at top of model (not used, but filling anyway)
+C
+      DO i=1,klon
+         sbh (i,limcnv) = sb(i,limcnv)
+         shbh(i,limcnv) = shb(i,limcnv)
+         hbh (i,limcnv) = hb(i,limcnv)
+      ENDDO
+C
+C Zero vertically independent control, tendency & diagnostic arrays
+C
+      DO i=1,klon
+         prec(i)  = 0.0
+         dzcld(i) = 0.0
+         cnb(i)   = 0
+         cnt(i)   = klev+1
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1,klon
+         cmfdt(i,k)  = 0.
+         cmfdq(i,k)  = 0.
+         cmfdqr(i,k) = 0.
+         cmfmc(i,k)  = 0.
+         cmfsl(i,k)  = 0.
+         cmflq(i,k)  = 0.
+        ENDDO
+      ENDDO
+C
+C Begin moist convective mass flux adjustment procedure.
+C Formalism ensures that negative cloud liquid water can never occur
+C
+      DO 70 k=klev-1,limcnv+1,-1
+         km1 = k - 1
+         kp1 = k + 1
+         DO 10 i=1,klon
+            eta   (i) = 0.0
+            beta  (i) = 0.0
+            ds1   (i) = 0.0
+            ds2   (i) = 0.0
+            ds3   (i) = 0.0
+            dq1   (i) = 0.0
+            dq2   (i) = 0.0
+            dq3   (i) = 0.0
+C
+C Specification of "cloud base" conditions
+C
+            qprime    = 0.0
+            tprime    = 0.0
+C
+C Assign tprime within the PBL to be proportional to the quantity
+C thtap (which will be bounded by tpmax), passed to this routine by 
+C the PBL routine.  Don't allow perturbation to produce a dry 
+C adiabatically unstable parcel.  Assign qprime within the PBL to be 
+C an appropriately modified value of the quantity shp (which will be 
+C bounded by shpmax) passed to this routine by the PBL routine.  The 
+C quantity qprime should be less than the local saturation value 
+C (qsattp=qsat[t+tprime,p]).  In both cases, thtap and shp are
+C linearly reduced toward zero as the PBL top is approached.
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.0) THEN
+               fac1   = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               tprime = MIN(thtap(i),tpmax)*fac1
+               qsattp = shbs(i,kp1) + RCPD/RLVTT*gam(i,kp1)*tprime
+               shprme = MIN(MIN(shp(i),shpmax)*fac1,
+     $                        MAX(qsattp-shb(i,kp1),0.0))
+               qprime = MAX(qprime,shprme)
+            ELSE
+               tprime = 0.0
+               qprime = 0.0
+            ENDIF
+C
+C Specify "updraft" (in-cloud) thermodynamic properties
+C
+            sc (i)    = sb (i,kp1) + RCPD*tprime
+            shc(i)    = shb(i,kp1) + qprime
+            hc (i)    = sc (i    ) + RLVTT*shc(i)
+            flotab(i) = hc(i) - hbs(i,k)
+            dz        = dp(i,k)*RD*tb(i,k)/RG/p(i,k)
+            IF (flotab(i).gt.0.0) THEN
+               dzcld(i) = dzcld(i) + dz
+            ELSE
+               dzcld(i) = 0.0
+            ENDIF
+   10    CONTINUE
+C
+C Check on moist convective instability
+C
+         is = 0
+         DO i = 1, klon
+            IF (flotab(i).GT.0.0) THEN
+               ldcum(i) = .TRUE.
+               is = is + 1
+            ELSE
+               ldcum(i) = .FALSE.
+            ENDIF
+         ENDDO
+C
+         IF (is.EQ.0) THEN
+            DO i=1,klon
+               dzcld(i) = 0.0
+            ENDDO
+            GOTO 70
+         ENDIF
+C
+C Current level just below top level => no overshoot
+C
+         IF (k.le.limcnv+1) THEN
+            DO i=1,klon
+            IF (ldcum(i)) THEN
+               cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+               cldwtr(i) = MAX(0.0,cldwtr(i))
+               beta(i)   = 0.0
+            ENDIF
+            ENDDO
+            GOTO 20
+         ENDIF
+C
+C First guess at overshoot parameter using crude buoyancy closure
+C 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
+C If pre-existing supersaturation in detrainment layer, beta=0
+C cldwtr is temporarily equal to RLVTT*l (l=> liquid water)
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+            cldwtr(i) = MAX(0.0,cldwtr(i))
+            betamx = 1.0 - c0*MAX(0.0,(dzcld(i)-dzmin))
+            b1        = (hc(i) - hbs(i,km1))*dp(i,km1)
+            b2        = (hc(i) - hbs(i,k  ))*dp(i,k  )
+            beta(i)   = MAX(betamn,MIN(betamx, 1.0+b1/b2))
+            IF (hbs(i,km1).le.hb(i,km1)) beta(i) = 0.0
+         ENDIF
+         ENDDO
+C
+C Bound maximum beta to ensure physically realistic solutions
+C
+C First check constrains beta so that eta remains positive
+C (assuming that eta is already positive for beta equal zero)
+c La premiere contrainte de beta est que le flux eta doit etre positif.
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.99*(tmp1/tmp2)
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+C
+C Second check involves supersaturation of "detrainment layer"
+C small amount of supersaturation acceptable (by ssfac factor)
+c La 2e contrainte est que la convection ne doit pas sursaturer
+c la "detrainment layer", Neanmoins, une petite sursaturation
+c est acceptee (facteur ssfac).
+C
+            IF (hb(i,km1).lt.hbs(i,km1)) THEN
+               tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $               - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+               tmp1 = tmp1/dp(i,k)
+               tmp2 = gam(i,km1)*(sbh(i,k)-sc(i) + cldwtr(i)) -
+     $                 hbh(i,k) + hc(i) - sc(i) + sbh(i,k)
+               tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+               tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2
+     $               / (dp(i,km1)*(hbs(i,km1)-hb(i,km1))) + tmp3
+               IF ((beta(i)*tmp4-tmp1).GT.0.0) THEN
+                  betamx = ssfac*(tmp1/tmp4)
+                  beta(i)   = MAX(0.0,MIN(betamx,beta(i)))
+               ENDIF
+            ELSE 
+               beta(i) = 0.0
+            ENDIF
+C
+C Third check to avoid introducing 2 delta x thermodynamic
+C noise in the vertical ... constrain adjusted h (or theta e)
+C so that the adjustment doesn't contribute to "kinks" in h
+C
+            g = MIN(0.0,hb(i,k)-hb(i,km1))
+            tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt) / (hc(i)-hbs(i,k))
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp1 = tmp1/dp(i,k)
+            tmp1 = tmp3*tmp1 + (hc(i) - hbh(i,kp1))/dp(i,k)
+            tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+     $            + (hc(i)-hbh(i,k)-cldwtr(i))
+     $             *(1.0/dp(i,k)+1.0/dp(i,kp1))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.0
+               IF (tmp2.NE.0.0) betamx = tmp1/tmp2
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C Calculate mass flux required for stabilization.
+C
+C Ensure that the convective mass flux, eta, is positive by
+C setting negative values of eta to zero..
+C Ensure that estimated mass flux cannot move more than the
+C minimum of total mass contained in either layer k or layer k+1.
+C Also test for other pathological cases that result in non-
+C physical states and adjust eta accordingly.
+C
+   20    CONTINUE
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            beta(i) = MAX(0.0,beta(i))
+            tmp1 = hc(i) - hbs(i,k)
+            tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) -
+     $               beta(i)*(1.0+gam(i,k))*(sc(i)-sbh(i,k)))/dp(i,k) -
+     $              (hbh(i,kp1)-hc(i))/dp(i,kp1)
+            eta(i) = tmp1/(tmp2*RG*cats)
+            tmass = MIN(dp(i,k),dp(i,kp1))/RG
+            IF (eta(i).GT.tmass*rdt .OR. eta(i).LE.0.0) eta(i) = 0.0
+C
+C Check on negative q in top layer (bound beta)
+C
+            IF(shc(i)-shbh(i,k).LT.0.0 .AND. beta(i)*eta(i).NE.0.0)THEN
+               denom = eta(i)*RG*dt*(shc(i) - shbh(i,k))/dp(i,km1)
+               beta(i) = MAX(0.0,MIN(-0.999*shb(i,km1)/denom,beta(i)))
+            ENDIF
+C
+C Check on negative q in middle layer (zero eta)
+C
+            qtest1 = shb(i,k) + eta(i)*RG*dt*((shc(i) - shbh(i,kp1)) -
+     $               (1.0 - beta(i))*cldwtr(i)/RLVTT -
+     $               beta(i)*(shc(i) - shbh(i,k)))/dp(i,k)
+            IF (qtest1.le.0.0) eta(i) = 0.0
+C
+C Check on negative q in lower layer (bound eta)
+C
+            fac1 = -(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            qtest2 = shb(i,kp1) - eta(i)*RG*dt*fac1
+            IF (qtest2 .lt. 0.0) THEN
+               eta(i) = 0.99*shb(i,kp1)/(RG*dt*fac1)
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C
+C Calculate cloud water, rain water, and thermodynamic changes
+C
+         DO 30 i=1,klon
+         IF (ldcum(i)) THEN
+            etagdt = eta(i)*RG*dt
+            cldwtr(i) = etagdt*cldwtr(i)/RLVTT/RG
+            rnwtr(i) = (1.0 - beta(i))*cldwtr(i)
+            ds1(i) = etagdt*(sbh(i,kp1) - sc(i))/dp(i,kp1)
+            dq1(i) = etagdt*(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            ds2(i) = (etagdt*(sc(i) - sbh(i,kp1)) +
+     $                RLVTT*RG*cldwtr(i) - beta(i)*etagdt*
+     $                (sc(i) - sbh(i,k)))/dp(i,k)
+            dq2(i) = (etagdt*(shc(i) - shbh(i,kp1)) -
+     $                RG*rnwtr(i) - beta(i)*etagdt*
+     $                (shc(i) - shbh(i,k)))/dp(i,k)
+            ds3(i) = beta(i)*(etagdt*(sc(i) - sbh(i,k)) -
+     $               RLVTT*RG*cldwtr(i))/dp(i,km1)
+            dq3(i) = beta(i)*etagdt*(shc(i) - shbh(i,k))/dp(i,km1)
+C
+C Isolate convective fluxes for later diagnostics
+C
+            fslkp = eta(i)*(sc(i) - sbh(i,kp1))
+            fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) -
+     $                       RLVTT*cldwtr(i)*rdt)
+            fqlkp = eta(i)*(shc(i) - shbh(i,kp1))
+            fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k))
+C
+C
+C Update thermodynamic profile (update sb, hb, & hbs later)
+C
+            tb (i,kp1) = tb(i,kp1)  + ds1(i) / RCPD
+            tb (i,k  ) = tb(i,k  )  + ds2(i) / RCPD
+            tb (i,km1) = tb(i,km1)  + ds3(i) / RCPD
+            shb(i,kp1) = shb(i,kp1) + dq1(i)
+            shb(i,k  ) = shb(i,k  ) + dq2(i)
+            shb(i,km1) = shb(i,km1) + dq3(i)
+            prec(i)    = prec(i)    + rnwtr(i)/rhoh2o
+C
+C Update diagnostic information for final budget
+C Tracking temperature & specific humidity tendencies,
+C rainout term, convective mass flux, convective liquid
+C water static energy flux, and convective total water flux
+C
+            cmfdt (i,kp1) = cmfdt (i,kp1) + ds1(i)/RCPD*rdt
+            cmfdt (i,k  ) = cmfdt (i,k  ) + ds2(i)/RCPD*rdt
+            cmfdt (i,km1) = cmfdt (i,km1) + ds3(i)/RCPD*rdt
+            cmfdq (i,kp1) = cmfdq (i,kp1) + dq1(i)*rdt
+            cmfdq (i,k  ) = cmfdq (i,k  ) + dq2(i)*rdt
+            cmfdq (i,km1) = cmfdq (i,km1) + dq3(i)*rdt
+            cmfdqr(i,k  ) = cmfdqr(i,k  ) + (RG*rnwtr(i)/dp(i,k))*rdt
+            cmfmc (i,kp1) = cmfmc (i,kp1) + eta(i)
+            cmfmc (i,k  ) = cmfmc (i,k  ) + beta(i)*eta(i)
+            cmfsl (i,kp1) = cmfsl (i,kp1) + fslkp
+            cmfsl (i,k  ) = cmfsl (i,k  ) + fslkm
+            cmflq (i,kp1) = cmflq (i,kp1) + RLVTT*fqlkp
+            cmflq (i,k  ) = cmflq (i,k  ) + RLVTT*fqlkm
+            qc    (i,k  ) =                (RG*rnwtr(i)/dp(i,k))*rdt
+         ENDIF
+   30    CONTINUE
+C
+C Next, convectively modify passive constituents
+C
+         DO 50 m=1,pcnst
+         DO 40 i=1,klon
+         IF (ldcum(i)) THEN
+C
+C If any of the reported values of the constituent is negative in
+C the three adjacent levels, nothing will be done to the profile
+C
+            IF ((cmrb(i,kp1,m).LT.0.0) .OR.
+     $          (cmrb(i,k,m).LT.0.0) .OR.
+     $          (cmrb(i,km1,m).LT.0.0)) GOTO 40
+C
+C Specify constituent interface values (linear interpolation)
+C
+            cmrh(i,k  ) = 0.5*(cmrb(i,km1,m) + cmrb(i,k  ,m))
+            cmrh(i,kp1) = 0.5*(cmrb(i,k  ,m) + cmrb(i,kp1,m))
+C
+C Specify perturbation properties of constituents in PBL
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.) THEN
+               fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               cmrc(i) = cmrb(i,kp1,m) + cmrp(i,m)*fac1
+            ELSE
+               cmrc(i) = cmrb(i,kp1,m)
+            ENDIF
+C
+C Determine fluxes, flux divergence => changes due to convection
+C Logic must be included to avoid producing negative values. A bit
+C messy since there are no a priori assumptions about profiles.
+C Tendency is modified (reduced) when pending disaster detected.
+C
+            etagdt = eta(i)*RG*dt
+            botflx   = etagdt*(cmrc(i) - cmrh(i,kp1))
+            topflx   = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
+            dcmr1(i) = -botflx/dp(i,kp1)
+            efac1    = 1.0
+            efac2    = 1.0
+            efac3    = 1.0
+C
+            IF (cmrb(i,kp1,m)+dcmr1(i) .LT. 0.0) THEN
+               efac1 = MAX(tiny,ABS(cmrb(i,kp1,m)/dcmr1(i)) - eps)
+            ENDIF
+C
+            IF (efac1.EQ.tiny .OR. efac1.GT.1.0) efac1 = 0.0
+            dcmr1(i) = -efac1*botflx/dp(i,kp1)
+            dcmr2(i) = (efac1*botflx - topflx)/dp(i,k)
+C  
+            IF (cmrb(i,k,m)+dcmr2(i) .LT. 0.0) THEN
+               efac2 = MAX(tiny,ABS(cmrb(i,k  ,m)/dcmr2(i)) - eps)
+            ENDIF
+C
+            IF (efac2.EQ.tiny .OR. efac2.GT.1.0) efac2 = 0.0
+            dcmr2(i) = (efac1*botflx - efac2*topflx)/dp(i,k)
+            dcmr3(i) = efac2*topflx/dp(i,km1)
+C
+            IF (cmrb(i,km1,m)+dcmr3(i) .LT. 0.0) THEN
+               efac3 = MAX(tiny,ABS(cmrb(i,km1,m)/dcmr3(i)) - eps)
+            ENDIF
+C
+            IF (efac3.EQ.tiny .OR. efac3.GT.1.0) efac3 = 0.0
+            efac3    = MIN(efac2,efac3)
+            dcmr2(i) = (efac1*botflx - efac3*topflx)/dp(i,k)
+            dcmr3(i) = efac3*topflx/dp(i,km1)
+C
+            cmrb(i,kp1,m) = cmrb(i,kp1,m) + dcmr1(i)
+            cmrb(i,k  ,m) = cmrb(i,k  ,m) + dcmr2(i)
+            cmrb(i,km1,m) = cmrb(i,km1,m) + dcmr3(i)
+         ENDIF
+   40    CONTINUE
+   50    CONTINUE              ! end of m=1,pcnst loop
+C
+         IF (k.EQ.limcnv+1) GOTO 60 ! on ne pourra plus glisser
+c
+c Dans la procedure de glissage ascendant, les variables thermo-
+c dynamiques des couches k et km1 servent au calcul des couches
+c superieures. Elles ont donc besoin d'une mise-a-jour.
+C
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            zx_t = tb(i,k)
+            zx_p = p(i,k)
+            zx_q = shb(i,k)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,k) = zx_qs
+            gam(i,k) = zx_gam
+c
+            zx_t = tb(i,km1)
+            zx_p = p(i,km1)
+            zx_q = shb(i,km1)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,km1) = zx_qs
+            gam(i,km1) = zx_gam
+C
+            sb (i,k  ) = sb(i,k  ) + ds2(i)
+            sb (i,km1) = sb(i,km1) + ds3(i)
+            hb (i,k  ) = sb(i,k  ) + RLVTT*shb(i,k)
+            hb (i,km1) = sb(i,km1) + RLVTT*shb(i,km1)
+            hbs(i,k  ) = sb(i,k  ) + RLVTT*shbs(i,k  )
+            hbs(i,km1) = sb(i,km1) + RLVTT*shbs(i,km1)
+C
+            sbh (i,k) = 0.5*(sb(i,k) + sb(i,km1))
+            shbh(i,k) = qhalf(shb(i,km1),shb(i,k)
+     $                       ,shbs(i,km1),shbs(i,k))
+            hbh (i,k) = sbh(i,k) + RLVTT*shbh(i,k)
+            sbh (i,km1) = 0.5*(sb(i,km1) + sb(i,k-2))
+            shbh(i,km1) = qhalf(shb(i,k-2),shb(i,km1),
+     $                    shbs(i,k-2),shbs(i,km1))
+            hbh (i,km1) = sbh(i,km1) + RLVTT*shbh(i,km1)
+         ENDIF
+         ENDDO
+C
+C Ensure that dzcld is reset if convective mass flux zero
+C specify the current vertical extent of the convective activity
+C top of convective layer determined by size of overshoot param.
+C
+   60    CONTINUE
+         DO i=1,klon
+            etagt0 = eta(i).gt.0.0
+            IF (.not.etagt0) dzcld(i) = 0.0
+            IF (etagt0 .and. beta(i).gt.betamn) THEN
+               ktp = km1
+            ELSE
+               ktp = k
+            ENDIF
+            IF (etagt0) THEN
+               cnt(i) = MIN(cnt(i),ktp)
+               cnb(i) = MAX(cnb(i),k)
+            ENDIF
+         ENDDO
+   70 CONTINUE        ! end of k loop
+C
+C determine whether precipitation, prec, is frozen (snow) or not
+C
+      DO i=1,klon
+         IF (tb(i,klev).LT.tmelt .AND. tb(i,klev-1).lt.tmelt) THEN
+             cmfprs(i) = prec(i)*rdt
+         ELSE
+             cmfprt(i) = prec(i)*rdt
+         ENDIF
+      ENDDO
+C
+      RETURN  ! we're all done ... return to calling procedure
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/concvl.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/concvl.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/concvl.F	(revision 984)
@@ -0,0 +1,452 @@
+
+!
+! $Header$
+!
+      SUBROUTINE concvl (iflag_con,iflag_clos,
+     .             dtime,paprs,pplay,
+     .             t,q,t_wake,q_wake,u,v,tra,ntra,
+     .             ALE,ALP,work1,work2,
+     .             d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop, sigd,
+     .             upwd,dnwd,dnwdbis,Ma,mip,Vprecip,
+     .             cape,cin,tvp,Tconv,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcondc,wd,pmflxr,pmflxs,
+     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
+***************************************************************
+*                                                             *
+* CONCVL                                                      *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
+* modified by :                                               *
+***************************************************************
+*
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c ALP-----input-R-puissance disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Ma------output-R-adiabatic ascent mass flux (kg/m2/s)
+c mip-----output-R-mass flux shed by adiabatic ascent (kg/m2/s)
+c Vprecip-output-R-vertical profile of precipitations (kg/m2/s)
+c Tconv---output-R-environment temperature seen by convective scheme (K)
+c Cape----output-R-CAPE (J/kg)
+c Cin ----output-R-CIN  (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c dd_t-----output-R-increment de la temperature du aux descentes precipitantes
+c dd_q-----output-R-increment de la vapeur d'eau du aux desc precip
+c======================================================================
+c
+#include "dimensions.h"
+cccccc#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       INTEGER iflag_con,iflag_clos
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL t_wake(klon,klev),q_wake(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev),ptop2(klon)
+       REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1)
+       REAL ALE(klon),ALP(klon)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL dd_t(klon,klev),dd_q(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)
+       real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+       REAL cape(klon),cin(klon),tvp(klon,klev)
+       REAL Tconv(klon,klev)
+c
+cCR:test: on passe lentr et alim_star des thermiques
+       INTEGER lalim_conv(klon)
+       REAL wght_th(klon,klev)
+       REAL em_sig1feed ! sigma at lower bound of feeding layer
+       REAL em_sig2feed ! sigma at upper bound of feeding layer
+       REAL em_wght(klev) ! weight density determining the feeding mixture
+con enleve le save
+c       SAVE em_sig1feed,em_sig2feed,em_wght
+c
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+       REAL qcondc(klon,klev)
+       REAL wd(klon)
+       REAL Plim1(klon),Plim2(klon),asupmax(klon,klev)
+       REAL supmax0(klon),asupmaxmin(klon)
+c
+       REAL sigd(klon)
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+!       INTEGER iflag_mix
+!       SAVE iflag_mix
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev),qs_wake(klon,klev)
+cLF       REAL cbmf(klon)
+cLF       SAVE cbmf
+       REAL, SAVE, ALLOCATABLE :: cbmf(:)
+c$OMP THREADPRIVATE(cbmf)!       
+       REAL cbmflast(klon)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+
+c
+C     Variables supplementaires liees au bilan d'energie
+c      Real paire(klon)
+cLF      Real ql(klon,klev)
+c      Save paire
+cLF      Save ql
+cLF      Real t1(klon,klev),q1(klon,klev)
+cLF      Save t1,q1
+c      Data paire /1./
+       REAL, SAVE, ALLOCATABLE :: ql(:,:), q1(:,:), t1(:,:)
+c$OMP THREADPRIVATE(ql, q1, t1)
+c
+C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/2/
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+      DATA      if_ebil/2/
+c+jld ec_conser
+      REAL d_t_ec(klon,klev)    ! tendance du a la conersion Ec -> E thermique
+      REAL ZRCPD
+c-jld ec_conser
+cLF
+      INTEGER nloc
+      logical, save :: first=.true.
+      INTEGER, SAVE :: itap, igout 
+c
+#include "YOMCST.h"
+#include "YOMCST2.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+c
+      if (first) then
+c Allocate some variables LF 04/2008
+c
+        allocate(cbmf(klon))
+        allocate(ql(klon,klev))
+        allocate(t1(klon,klev))
+        allocate(q1(klon,klev))
+        itap=0
+        igout=klon/2+1/klon
+      endif
+c Incrementer le compteur de la physique
+      itap   = itap + 1
+
+c    Copy T into Tconv
+      DO k = 1,klev
+        DO i = 1,klon
+          Tconv(i,k) = T(i,k)
+        ENDDO
+      ENDDO
+c
+      IF (if_ebil.ge.1) THEN
+        DO i=1,klon
+          ztsol(i) = t(i,1)
+          zero_v(i)=0.
+          Do k = 1,klev
+            ql(i,k) = 0.
+          ENDDO
+        END DO
+      END IF
+c
+cym
+      snow(:)=0
+      
+c      IF (ifrst .EQ. 0) THEN
+c         ifrst = 1
+       if (first) then
+         first=.false.
+c
+C===========================================================================
+C    READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
+C===========================================================================
+C
+      if (iflag_con.eq.3) then
+c     CALL cv3_inicp()
+      CALL cv3_inip()
+      endif
+c
+C===========================================================================
+C    READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+C===========================================================================
+C
+c$$$         open (56,file='supcrit.data')
+c$$$         read (56,*) Supcrit1, Supcrit2
+c$$$         close (56)
+c
+         print*, 'supcrit1, supcrit2' ,supcrit1, supcrit2
+C
+C===========================================================================
+C      Initialisation pour les bilans d'eau et d'energie
+C===========================================================================
+         IF (if_ebil.ge.1) d_h_vcol_phy=0.
+c
+         DO i = 1, klon
+          cbmf(i) = 0.
+          sigd(i) = 0.
+         ENDDO
+      ENDIF   !(ifrst .EQ. 0)
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+         pmflxs(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+c
+!
+!  Feeding layer
+!
+      em_sig1feed = 1.
+      em_sig2feed = 0.97
+c      em_sig2feed = 0.8
+! Relative Weight densities
+       do k=1,klev
+         em_wght(k)=1.
+       end do
+cCRtest: couche alim des tehrmiques ponderee par a*
+c       DO i = 1, klon
+c         do k=1,lalim_conv(i)
+c         em_wght(k)=wght_th(i,k)
+c         print*,'em_wght=',em_wght(k),wght_th(i,k)
+c       end do
+c      END DO
+
+      if (iflag_con .eq. 4) then
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+        DO i = 1, klon
+         zx_t = t_wake(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs_wake(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+      else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs(i,k)=zx_qs
+        ENDDO
+        DO i = 1, klon
+         zx_t = t_wake(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs_wake(i,k)=zx_qs
+        ENDDO
+      ENDDO
+      endif ! iflag_con
+c
+C------------------------------------------------------------------
+
+C Main driver for convection:
+C               iflag_con=3 -> nvlle version de KE (JYG)
+C		iflag_con = 30  -> equivalent to convect3
+C		iflag_con = 4  -> equivalent to convect1/2
+c
+c
+      if (iflag_con.eq.30) then
+
+      CALL cv_driver(klon,klev,klev+1,ntra,iflag_con,
+     :              t,q,qs,u,v,tra,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,d_tra,rain,
+     $              pmflxr,cbmf,work1,work2,
+     $              kbas,ktop,
+     $              dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape,
+     $              da,phi,mp)
+      
+      else
+
+cLF   necessary for gathered fields
+      nloc=klon
+      CALL cva_driver(klon,klev,klev+1,ntra,nloc,
+     $              iflag_con,iflag_mix,iflag_clos,dtime,
+     :              t,q,qs,t_wake,q_wake,qs_wake,u,v,tra,
+     $              em_p,em_ph,
+     .              ALE,ALP,
+     .              em_sig1feed,em_sig2feed,em_wght,
+     .              iflag,d_t,d_q,d_u,d_v,d_tra,rain,kbas,ktop,
+     $              cbmf,work1,work2,ptop2,sigd,
+     $              Ma,mip,Vprecip,upwd,dnwd,dnwdbis,qcondc,wd,
+     $              cape,cin,tvp,
+     $              dd_t,dd_q,Plim1,Plim2,asupmax,supmax0,
+     $              asupmaxmin,lalim_conv)
+      endif  
+C------------------------------------------------------------------
+
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+      ENDDO
+c
+       if (iflag_con.eq.30) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO 
+       endif
+
+      DO k = 1, klev
+        DO i = 1, klon
+          t1(i,k) = t(i,k)+ d_t(i,k)
+          q1(i,k) = q(i,k)+ d_q(i,k)
+        ENDDO
+      ENDDO
+c
+cc      IF (if_ebil.ge.2) THEN
+cc        ztit='after convect'
+cc        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+cc     e      , t1,q1,ql,qs,u,v,paprs,pplay
+cc     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+cc         call diagphy(paire,ztit,ip_ebil
+cc     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+cc     e      , zero_v, rain, zero_v, ztsol
+cc     e      , d_h_vcol, d_qt, d_ec
+cc     s      , fs_bound, fq_bound )
+cc      END IF
+C
+c
+c les traceurs ne sont pas mis dans cette version de convect4:
+      if (iflag_con.eq.4) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+         ENDDO
+        ENDDO
+       ENDDO
+      endif
+c     print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
+
+        DO k = 1, klev
+         DO i = 1, klon
+            dtvpdt1(i,k) = 0.
+            dtvpdq1(i,k) = 0.
+         ENDDO
+        ENDDO
+        DO i = 1, klon
+           dplcldt(i) = 0.
+           dplcldr(i) = 0.
+        ENDDO
+c
+       if(prt_level.GE.20) THEN
+       DO k=1,klev
+!       print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout
+!    .,k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k),
+!    .d_q_con(igout,k),dql0(igout,k)
+!      print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q'
+!    .,itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout),
+!    . t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
+!      print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip'
+!    .,itap,rain_con(igout),snow_con(igout),ema_work1(igout,k),
+!    .ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
+!      print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv '
+!    .,itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout),
+!    .tvp(igout,k),Tconv(igout,k)
+!      print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc'
+!    .,itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout),
+!    .dplcldr(igout),qcondc(igout,k)
+!      print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1'
+!    .,itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k)
+!    .,pmflxs(igout,k+1)
+!      print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth',
+!    .itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k),
+!    . fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
+      ENDDO
+      endif !(prt_level.EQ.20) THEN
+c
+      RETURN
+      END
+ 
Index: LMDZ4/tags/LF_20080728/libf/phylmd/condsurf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/condsurf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/condsurf.F	(revision 984)
@@ -0,0 +1,139 @@
+c $Header$
+c
+      SUBROUTINE condsurf( jour, jourvrai, lmt_bils )
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+c
+c I. Musat 05.2005
+c
+c Lire chaque jour le bilan de chaleur au sol issu 
+c d'un run atmospherique afin de l'utiliser dans
+c dans un run "slab" ocean 
+c -----------------------------------------
+c jour     : input  , numero du jour a lire
+c jourvrai : input  , vrai jour de la simulation  
+c
+c lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean")
+c
+#include "netcdf.inc"
+      INTEGER nid, nvarid
+      INTEGER debut(2)
+      INTEGER epais(2)
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+#include "temps.h"
+#include "clesphys.h"
+c
+      INTEGER     nannemax
+      PARAMETER ( nannemax = 60 )
+c
+      INTEGER jour, jourvrai
+      REAL lmt_bils(klon) !bilan chaleur au sol
+c
+c Variables locales:
+      INTEGER ig, i, kt, ierr
+      LOGICAL ok
+      INTEGER anneelim,anneemax
+      CHARACTER*20 fich
+      
+      REAL :: lmt_bils_glo(klon_glo)
+      
+cc
+cc   .....................................................................
+cc
+cc    Pour lire le fichier limit correspondant vraiment  a l'annee de la
+cc     simulation en cours , il suffit de mettre  ok_limitvrai = .TRUE.
+cc
+cc   ......................................................................
+c
+c
+      
+      IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
+         PRINT*,'Le jour demande n est pas correct: ', jour
+         CALL ABORT
+      ENDIF
+c
+       anneelim  = annee_ref
+       anneemax  = annee_ref + nannemax
+c
+c
+       IF( ok_limitvrai )       THEN
+          DO  kt = 1, nannemax
+           IF(jourvrai.LE. (kt-1)*360 + 359  )  THEN
+              WRITE(fich,'("limit",i4,".nc")') anneelim
+c             PRINT *,' Fichier  Limite ',fich
+              GO TO 100
+             ENDIF
+           anneelim = anneelim + 1
+          ENDDO
+
+         PRINT *,' PBS ! Le jour a lire sur le fichier limit ne se '
+         PRINT *,' trouve pas sur les ',nannemax,' annees a partir de '
+         PRINT *,' l annee de debut', annee_ref
+         CALL EXIT(1)
+c
+100     CONTINUE
+c
+       ELSE
+     
+            WRITE(fich,'("limitNEW.nc")') 
+c           PRINT *,' Fichier  Limite ',fich
+       ENDIF
+c
+c Ouvrir le fichier en format NetCDF:
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        WRITE(6,*)' Pb d''ouverture du fichier ', fich
+        WRITE(6,*)' Le fichier limit ',fich,' (avec 4 chiffres , pour' 
+        WRITE(6,*)'       l an 2000 )  ,  n existe  pas !  ' 
+        WRITE(6,*)' ierr = ', ierr
+        CALL EXIT(1)
+      ENDIF
+c     DO k = 1, jour
+c La tranche de donnees a lire:
+c
+      debut(1) = 1
+      debut(2) = jourvrai
+      epais(1) = klon_glo
+      epais(2) = 1
+c Bilan flux de chaleur au sol:
+c
+      ierr = NF_INQ_VARID (nid, "BILS", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <BILS> est absent"
+         CALL abort
+      ENDIF
+      PRINT*,'debut,epais',debut,epais,'jour,jourvrai',jour,jourvrai
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_bils_glo)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_bils_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <BILS>"
+         CALL abort
+      ENDIF
+c     ENDDO !k = 1, jour
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+      
+      ENDIF ! is_mpi_root==0
+
+c$OMP END MASTER
+      CALL scatter(lmt_bils_glo,lmt_bils)
+            
+c
+c
+c     PRINT*, 'lmt_bils est lu pour jour: ', jour
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conema3.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conema3.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conema3.F	(revision 984)
@@ -0,0 +1,421 @@
+!
+! $Header$
+!
+      SUBROUTINE conema3 (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,bas,top,Ma,cape,tvp,rflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcond_incld)
+
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c Mai 1998: Interface modifiee pour implementation dans LMDZ
+c======================================================================
+c Arguments:
+c dtime---input-R-pas d'integration (s)
+c paprs---input-R-pression inter-couches (Pa)
+c pplay---input-R-pression au milieu des couches (Pa)
+c t-------input-R-temperature (K)
+c q-------input-R-humidite specifique (kg/kg)
+c u-------input-R-vitesse du vent zonal (m/s)
+c v-------input-R-vitesse duvent meridien (m/s)
+c tra-----input-R-tableau de rapport de melange des traceurs
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c
+C d_t-----output-R-increment de la temperature
+c d_q-----output-R-increment de la vapeur d'eau
+c d_u-----output-R-increment de la vitesse zonale
+c d_v-----output-R-increment de la vitesse meridienne
+c d_tra---output-R-increment du contenu en traceurs
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c kbas----output-R-bas du nuage (integer)
+c ktop----output-R-haut du nuage (integer)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c bas-----output-R-bas du nuage (real)
+c top-----output-R-haut du nuage (real)
+c Ma------output-R-flux ascendant non dilue (kg/m**2/s)
+c cape----output-R-CAPE
+c tvp-----output-R-virtual temperature of the lifted parcel
+c rflag---output-R-flag sur le fonctionnement de convect
+c pbase---output-R-pression a la base du nuage (Pa)
+c bbase---output-R-buoyancy a la base du nuage (K)
+c dtvpdt1-output-R-derivative of parcel virtual temp wrt T1 
+c dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1 
+c dplcldt-output-R-derivative of the PCP pressure wrt T1
+c dplcldr-output-R-derivative of the PCP pressure wrt Q1
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "conema3.h"
+      INTEGER i, l,m,itra
+      INTEGER ntra,ntrac !number of tracers; if no tracer transport
+                         ! is needed, set ntra = 1 (or 0)
+      PARAMETER (ntrac=nqmx-2)
+      REAL dtime
+c
+      REAL d_t2(klon,klev), d_q2(klon,klev) ! sbl
+      REAL d_u2(klon,klev), d_v2(klon,klev) ! sbl
+      REAL em_d_t2(klev), em_d_q2(klev)     ! sbl   
+      REAL em_d_u2(klev), em_d_v2(klev)     ! sbl   
+c 
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), d_t(klon,klev), d_q(klon,klev)
+      REAL u(klon,klev), v(klon,klev), tra(klon,klev,ntra)
+      REAL d_u(klon,klev), d_v(klon,klev), d_tra(klon,klev,ntra)
+      REAL work1(klon,klev), work2(klon,klev)
+      REAL upwd(klon,klev), dnwd(klon,klev), dnwdbis(klon,klev)
+      REAL rain(klon)
+      REAL snow(klon)
+      REAL cape(klon), tvp(klon,klev), rflag(klon)
+      REAL pbase(klon), bbase(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+      INTEGER kbas(klon), ktop(klon)
+
+      REAL wd(klon)
+      REAL qcond_incld(klon,klev)
+c
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+      
+cym      REAL em_t(klev)
+      REAL,ALLOCATABLE,SAVE :: em_t(:)
+c$OMP THREADPRIVATE(em_t)  
+cym      REAL em_q(klev)
+      REAL,ALLOCATABLE,SAVE :: em_q(:)
+c$OMP THREADPRIVATE(em_q) 
+cym      REAL em_qs(klev)
+      REAL,ALLOCATABLE,SAVE :: em_qs(:) 
+c$OMP THREADPRIVATE(em_qs)  
+cym      REAL em_u(klev), em_v(klev), em_tra(klev,ntrac)
+      REAL,ALLOCATABLE,SAVE :: em_u(:),em_v(:),em_tra(:,:)
+c$OMP THREADPRIVATE(em_u,em_v,em_tra)      
+cym      REAL em_ph(klev+1), em_p(klev)
+      REAL,ALLOCATABLE,SAVE ::em_ph(:),em_p(:)
+c$OMP THREADPRIVATE(em_ph,em_p)
+cym      REAL em_work1(klev), em_work2(klev)
+      REAL,ALLOCATABLE,SAVE ::em_work1(:),em_work2(:)
+c$OMP THREADPRIVATE(em_work1,em_work2)      
+cym      REAL em_precip, em_d_t(klev), em_d_q(klev)
+      REAL,SAVE :: em_precip
+c$OMP THREADPRIVATE(em_precip)      
+      REAL,ALLOCATABLE,SAVE :: em_d_t(:),em_d_q(:)
+c$OMP THREADPRIVATE(em_d_t,em_d_q)
+cym      REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac)
+      REAL,ALLOCATABLE,SAVE ::em_d_u(:),em_d_v(:),em_d_tra(:,:)
+c$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra)      
+cym      REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)
+      REAL,ALLOCATABLE,SAVE :: em_upwd(:),em_dnwd(:),em_dnwdbis(:)
+c$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis)
+      REAL em_dtvpdt1(klev), em_dtvpdq1(klev)
+      REAL em_dplcldt, em_dplcldr
+cym      SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2
+cym      SAVE em_u,em_v, em_tra
+cym      SAVE em_d_u,em_d_v, em_d_tra
+cym      SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis
+
+      INTEGER em_bas, em_top
+      SAVE em_bas, em_top
+c$OMP THREADPRIVATE(em_bas,em_top)
+      REAL em_wd
+      REAL em_qcond(klev)
+      REAL em_qcondc(klev)
+c
+      REAL zx_t, zx_qs, zdelta, zcor
+      INTEGER iflag
+      REAL sigsum
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     VARIABLES A SORTIR
+cccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+cym      REAL emmip(klev) !variation de flux ascnon dilue i et i+1
+      REAL,ALLOCATABLE,SAVE ::emmip(:)
+c$OMP THREADPRIVATE(emmip)
+cym      SAVE emmip
+cym      real emMke(klev)
+      REAL,ALLOCATABLE,SAVE ::emMke(:)
+c$OMP THREADPRIVATE(emMke)
+cym      save emMke
+      real top
+      real bas
+cym      real emMa(klev)
+      REAL,ALLOCATABLE,SAVE ::emMa(:)
+c$OMP THREADPRIVATE(emMa)
+cym      save emMa
+      real Ma(klon,klev)
+      real Ment(klev,klev)
+      real Qent(klev,klev)
+      real TPS(klev),TLS(klev)
+      real SIJ(klev,klev)
+      real em_CAPE, em_TVP(klev)
+      real em_pbase, em_bbase
+      integer iw,j,k,ix,iy
+
+c -- sb: pour schema nuages:
+
+       integer iflagcon
+       integer em_ifc(klev)
+     
+       real em_pradj
+       real em_cldf(klev), em_cldq(klev)
+       real em_ftadj(klev), em_fradj(klev)
+
+       integer ifc(klon,klev)
+       real pradj(klon)
+       real cldf(klon,klev), cldq(klon,klev)
+       real ftadj(klon,klev), fqadj(klon,klev)
+
+c sb --
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+     
+      if (first) then
+  
+        allocate(em_t(klev))
+        allocate(em_q(klev))
+        allocate(em_qs(klev))
+        allocate(em_u(klev), em_v(klev), em_tra(klev,ntrac))
+        allocate(em_ph(klev+1), em_p(klev))
+        allocate(em_work1(klev), em_work2(klev))
+        allocate(em_d_t(klev), em_d_q(klev))
+        allocate(em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac))
+        allocate(em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev))
+        allocate(emmip(klev)) 
+	allocate(emMke(klev))
+        allocate(emMa(klev))
+  
+        first=.false.
+      endif
+  
+      qcond_incld(:,:) = 0.
+c
+c@$$      print*,'debut conema'
+
+      DO 999 i = 1, klon
+      DO l = 1, klev+1
+         em_ph(l) = paprs(i,l) / 100.0
+      ENDDO
+c
+      DO l = 1, klev
+         em_p(l) = pplay(i,l) / 100.0
+         em_t(l) = t(i,l)
+         em_q(l) = q(i,l)
+         em_u(l) = u(i,l)
+         em_v(l) = v(i,l)
+         do itra = 1, ntra
+          em_tra(l,itra) = tra(i,l,itra)
+         enddo
+c@$$      print*,'em_t',em_t
+c@$$      print*,'em_q',em_q
+c@$$      print*,'em_qs',em_qs
+c@$$      print*,'em_u',em_u
+c@$$      print*,'em_v',em_v
+c@$$      print*,'em_tra',em_tra
+c@$$      print*,'em_p',em_p
+
+ 
+c
+         zx_t = em_t(l)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(l)/100.0
+         zx_qs=MIN(0.5,zx_qs)
+c@$$       print*,'zx_qs',zx_qs
+         zcor=1./(1.-retv*zx_qs) 
+         zx_qs=zx_qs*zcor
+         em_qs(l) = zx_qs
+c@$$      print*,'em_qs',em_qs
+c
+         em_work1(l) = work1(i,l)
+         em_work2(l) = work2(i,l)
+         emMke(l)=0
+c        emMa(l)=0
+c        Ma(i,l)=0
+     
+         em_dtvpdt1(l) = 0.
+         em_dtvpdq1(l) = 0.
+         dtvpdt1(i,l) = 0.
+         dtvpdq1(i,l) = 0.
+      ENDDO
+c
+      em_dplcldt = 0.
+      em_dplcldr = 0.
+      rain(i) = 0.0
+      snow(i) = 0.0
+      kbas(i) = 1
+      ktop(i) = 1
+c ajout SB:
+      bas = 1
+      top = 1
+ 
+ 
+c sb3d      write(*,1792) (em_work1(m),m=1,klev)
+1792  format('sig avant convect ',/,10(1X,E13.5))
+c
+c sb d      write(*,1793) (em_work2(m),m=1,klev)
+1793  format('w avant convect ',/,10(1X,E13.5))
+ 
+c@$$      print*,'avant convect' 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c 
+
+c     print*,'avant convect i=',i
+      CALL convect3(dtime,epmax,ok_adj_ema,
+     .              em_t, em_q, em_qs,em_u ,em_v ,
+     .              em_tra, em_p, em_ph,
+     .              klev, klev+1, klev-1,ntra, dtime, iflag,
+     .              em_d_t, em_d_q,em_d_u,em_d_v,
+     .              em_d_tra, em_precip,
+     .              em_bas, em_top,em_upwd, em_dnwd, em_dnwdbis,
+     .              em_work1, em_work2,emmip,emMke,emMa,Ment,
+     .  Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase,
+     .  em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr, ! sbl
+     .  em_d_t2,em_d_q2,em_d_u2,em_d_v2,em_wd,em_qcond,em_qcondc)!sbl
+c     print*,'apres convect '
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c -- sb: Appel schema statistique de nuages couple a la convection
+c (Bony et Emanuel 2001):
+
+c -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ:
+
+        iflagcon = 3
+c       CALL cv_thermo(iflagcon)
+
+c -- appel schema de nuages:
+
+c       CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t
+c    i          ,em_p,em_ph,dtime,em_qcondc
+c    o          ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc)
+
+        do k = 1, klev 
+         cldf(i,k)  = em_cldf(k)  ! cloud fraction (0-1)
+         cldq(i,k)  = em_cldq(k)  ! in-cloud water content (kg/kg)
+         ftadj(i,k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s)
+         fqadj(i,k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s)
+         ifc(i,k)   = em_ifc(k)   ! flag convergence clouds_gno (1 ou 2)
+        enddo
+        pradj(i) = em_pradj       ! precip from LS supersat adj (mm/day)
+
+c sb --
+c
+c SB:
+      if (iflag.ne.1 .and. iflag.ne.4) then
+         em_CAPE = 0.
+      do l = 1, klev
+         em_upwd(l) = 0.
+         em_dnwd(l) = 0.
+         em_dnwdbis(l) = 0.
+         emMa(l) = 0.
+         em_TVP(l) = 0.
+      enddo
+      endif
+c fin SB
+c
+c  If sig has been set to zero, then set Ma to zero
+c
+      sigsum = 0.
+      do k = 1,klev
+        sigsum = sigsum + em_work1(k)
+      enddo
+      if (sigsum .eq. 0.0) then
+        do k = 1,klev
+          emMa(k) = 0.
+        enddo
+      endif
+c
+c sb3d       print*,'i, iflag=',i,iflag
+c 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c       SORTIE DES ICB ET INB
+c       en fait inb et icb correspondent au niveau ou se trouve
+c       le nuage,le numero d'interface
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+c modif SB:
+      if (iflag.EQ.1 .or. iflag.EQ.4) then
+       top=em_top
+       bas=em_bas
+       kbas(i) = em_bas
+       ktop(i) = em_top
+      endif
+ 
+      pbase(i) = em_pbase
+      bbase(i) = em_bbase
+      rain(i) = em_precip/ 86400.0
+      snow(i) = 0.0
+      cape(i) = em_CAPE
+      wd(i) = em_wd
+      rflag(i) = float(iflag)
+c SB      kbas(i) = em_bas
+c SB      ktop(i) = em_top
+      dplcldt(i) = em_dplcldt
+      dplcldr(i) = em_dplcldr
+      DO l = 1, klev
+         d_t2(i,l) = dtime * em_d_t2(l) 
+         d_q2(i,l) = dtime * em_d_q2(l)
+         d_u2(i,l) = dtime * em_d_u2(l)
+         d_v2(i,l) = dtime * em_d_v2(l)
+
+         d_t(i,l) = dtime * em_d_t(l) 
+         d_q(i,l) = dtime * em_d_q(l)
+         d_u(i,l) = dtime * em_d_u(l)
+         d_v(i,l) = dtime * em_d_v(l)
+         do itra = 1, ntra
+         d_tra(i,l,itra) = dtime * em_d_tra(l,itra)
+         enddo
+         upwd(i,l) = em_upwd(l)
+         dnwd(i,l) = em_dnwd(l)
+         dnwdbis(i,l) = em_dnwdbis(l)
+         work1(i,l) = em_work1(l)
+         work2(i,l) = em_work2(l)
+         Ma(i,l)=emMa(l)
+         tvp(i,l)=em_TVP(l)
+         dtvpdt1(i,l) = em_dtvpdt1(l)
+         dtvpdq1(i,l) = em_dtvpdq1(l)
+
+         if (iflag_clw.eq.0) then
+            qcond_incld(i,l) = em_qcondc(l)
+         else if (iflag_clw.eq.1) then
+            qcond_incld(i,l) = em_qcond(l)
+         endif
+      ENDDO
+  999 CONTINUE
+
+c   On calcule une eau liquide diagnostique en fonction de la 
+c  precip.
+      if ( iflag_clw.eq.2 ) then
+      do l=1,klev
+         do i=1,klon
+            if (ktop(i)-kbas(i).gt.0.and.
+     s         l.ge.kbas(i).and.l.le.ktop(i)) then
+               qcond_incld(i,l)=rain(i)*8.e4
+c    s         *(pplay(i,l      )-paprs(i,ktop(i)+1))
+     s         /(pplay(i,kbas(i))-pplay(i,ktop(i)))
+c    s         **2
+            else
+               qcond_incld(i,l)=0.
+            endif
+         enddo
+         print*,'l=',l,',   qcond_incld=',qcond_incld(1,l)
+      enddo
+      endif
+ 
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conema3.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conema3.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conema3.h	(revision 984)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!-- Modified by : Filiberti M-A 06/2005
+!
+      real epmax             ! 0.993
+      logical ok_adj_ema      ! F
+      integer iflag_clw      ! 0
+	  integer iflag_cvl_sigd
+      real sig1feed      ! 1.
+      real sig2feed      ! 0.95
+
+      common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed
+      common/comconema2/iflag_cvl_sigd
+
+!      common/comconema/epmax,ok_adj_ema,iflag_clw
+!$OMP THREADPRIVATE(/comconema1/)
+!$OMP THREADPRIVATE(/comconema2/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conemav.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conemav.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conemav.F	(revision 984)
@@ -0,0 +1,155 @@
+!
+! $Header$
+!
+      SUBROUTINE conemav (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+ 
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Cape----output-R-CAPE (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev),cape(klon),tvp(klon,klev)
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+c
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev)
+cym       REAL cbmf(klon)
+cym       SAVE cbmf
+       REAL,ALLOCATABLE,SAVE :: cbmf(:)
+c$OMP THREADPRIVATE(cbmf)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c
+      IF (ifrst .EQ. 0) THEN
+         ifrst = 1
+	 allocate(cbmf(klon))
+         DO i = 1, klon
+          cbmf(i) = 0.
+         ENDDO
+      ENDIF
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+
+c
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+c
+      noff = 2
+      minorig = 2
+      CALL convect1(klon,klev,klev+1,noff,minorig,t,q,qs,u,v,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,rain,cbmf,dtime,Ma)
+c
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+c      call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION   ')
+c     if (klon.eq.1) then
+c        print*,'IFLAG ',iflag
+c     else
+c        write(*,'(96i1)') (iflag(i),i=2,klon-1)
+c     endif
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+        DO itra = 1,ntra
+          DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+          ENDDO
+        ENDDO
+      ENDDO
+ 
+c
+c
+c
+      RETURN
+      END
+ 
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conf_phys.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conf_phys.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conf_phys.F90	(revision 984)
@@ -0,0 +1,1354 @@
+!
+! $Header$
+!
+!
+!
+
+  subroutine conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, ok_instan, ok_hf, &
+ &                     solarlong0,seuil_inversion, &
+ &                     fact_cldcon, facttemps,ok_newmicro,iflag_radia,&
+ &                     iflag_cldcon, &
+ &                     iflag_ratqs,ratqsbas,ratqshaut, &
+ &		       ok_ade, ok_aie, aerosol_couple, &
+ &                     bl95_b0, bl95_b1,&
+ &                     iflag_thermals,nsplit_thermals,tau_thermals, &
+ &                     iflag_coupl,iflag_clos,iflag_wake )
+
+   use IOIPSL
+!!!!   USE surface_data,     ONLY : ocean, ok_veget
+
+   implicit none
+
+ include "conema3.h"
+ include "fisrtilp.h"
+ include "nuage.h"
+ include "YOMCST.h"
+ include "YOMCST2.h"
+!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
+include "clesphys.h"
+include "compbl.h"
+include "control.h"
+include "comsoil.h"
+!
+! Configuration de la "physique" de LMDZ a l'aide de la fonction
+! GETIN de IOIPSL
+!
+! LF 05/2001
+!
+
+!
+! ocean:      type d'ocean (force, slab, couple)
+! ok_veget:   type de modele de vegetation
+! ok_journe:  sorties journalieres
+! ok_hf:  sorties haute frequence
+! ok_mensuel: sorties mensuelles
+! ok_instan:  sorties instantanees
+! ok_ade, ok_aie: apply or not aerosol direct and indirect effects
+! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 
+!
+
+
+! Sortie:
+  character (len = 6)  :: ocean
+  logical              :: ok_veget, ok_newmicro
+  integer              :: iflag_radia
+  logical              :: ok_journe, ok_mensuel, ok_instan, ok_hf
+  LOGICAL              :: ok_ade, ok_aie, aerosol_couple
+  REAL                 :: bl95_b0, bl95_b1
+  real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut
+  integer              :: iflag_cldcon
+  integer              :: iflag_ratqs
+
+  character (len = 6),SAVE  :: ocean_omp
+  logical,SAVE              :: ok_veget_omp, ok_newmicro_omp
+  logical,SAVE        :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp        
+  LOGICAL,SAVE        :: ok_ade_omp, ok_aie_omp, aerosol_couple_omp
+  REAL,SAVE           :: bl95_b0_omp, bl95_b1_omp
+  REAL,SAVE           :: freq_ISCCP_omp, ecrit_ISCCP_omp
+  real,SAVE           :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp
+  real,SAVE           :: ratqshaut_omp
+  integer,SAVE        :: iflag_radia_omp
+  integer,SAVE        :: iflag_cldcon_omp, ip_ebil_phy_omp
+  integer,SAVE        :: iflag_ratqs_omp
+
+! Local
+  integer              :: numout = 6
+  real                 :: zzz
+
+  real :: seuil_inversion
+  real,save :: seuil_inversion_omp
+
+  integer :: iflag_thermals,nsplit_thermals
+  integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
+  real :: tau_thermals
+  real,save :: tau_thermals_omp
+  integer :: iflag_coupl
+  integer :: iflag_clos
+  integer :: iflag_wake
+  integer,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp
+  integer,SAVE :: iflag_cvl_sigd_omp
+  REAL, SAVE :: supcrit1_omp, supcrit2_omp
+  INTEGER, SAVE :: iflag_mix_omp
+  real, save :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp
+
+  REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp,co2_ppm_omp
+  REAL,SAVE :: RCO2_omp,CH4_ppb_omp,RCH4_omp,N2O_ppb_omp,RN2O_omp,CFC11_ppt_omp
+  REAL,SAVE :: RCFC11_omp,CFC12_ppt_omp,RCFC12_omp,epmax_omp
+  LOGICAL,SAVE :: ok_adj_ema_omp
+  INTEGER,SAVE :: iflag_clw_omp
+  REAL,SAVE :: cld_lc_lsc_omp,cld_lc_con_omp,cld_tau_lsc_omp,cld_tau_con_omp
+  REAL,SAVE :: ffallv_lsc_omp, ffallv_con_omp,coef_eva_omp
+  LOGICAL,SAVE :: reevap_ice_omp
+  INTEGER,SAVE :: iflag_pdf_omp
+  REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
+  REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_ice_omp
+  REAL,SAVE :: qsol0_omp
+  REAL      :: solarlong0
+  REAL,SAVE :: solarlong0_omp
+  INTEGER,SAVE :: top_height_omp,overlap_omp
+  REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp
+  LOGICAL,SAVE :: ok_kzmin_omp
+  REAL, SAVE ::  fmagic_omp, pmagic_omp
+  INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp
+  CHARACTER*4, SAVE :: type_run_omp
+  LOGICAL,SAVE :: ok_isccp_omp
+  REAL,SAVE :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp
+  REAL,SAVE :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp
+  REAL,SAVE :: ecrit_tra_omp
+  LOGICAL, SAVE :: ok_slab_sicOBS_omp
+  REAL,SAVE :: cvl_corr_omp
+  LOGICAL,SAVE :: ok_lic_melt_omp
+!
+!
+    LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp
+    LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
+    INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
+!
+
+!$OMP MASTER
+!Config Key  = OCEAN 
+!Config Desc = Type d'ocean
+!Config Def  = force
+!Config Help = Type d'ocean utilise: force, slab,couple
+!
+  ocean_omp = 'force '
+  call getin('OCEAN', ocean_omp)
+!
+!Config Key  = VEGET 
+!Config Desc = Type de modele de vegetation
+!Config Def  = .false.
+!Config Help = Type de modele de vegetation utilise
+!
+  ok_veget_omp = .false.
+  call getin('VEGET', ok_veget_omp)
+!
+!Config Key  = OK_journe
+!Config Desc = Pour des sorties journalieres 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histday contenant les sorties
+!              journalieres 
+!
+  ok_journe_omp = .false.
+  call getin('OK_journe', ok_journe_omp)
+!
+!Config Key  = ok_hf
+!Config Desc = Pour des sorties haute frequence
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histhf contenant les sorties
+!              haute frequence ( 3h ou 6h)
+!
+  ok_hf_omp = .false.
+  call getin('ok_hf', ok_hf_omp)
+!
+!Config Key  = OK_mensuel
+!Config Desc = Pour des sorties mensuelles 
+!Config Def  = .true.
+!Config Help = Pour creer le fichier histmth contenant les sorties
+!              mensuelles 
+!
+  ok_mensuel_omp = .true.
+  call getin('OK_mensuel', ok_mensuel_omp)
+!
+!Config Key  = OK_instan
+!Config Desc = Pour des sorties instantanees 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histins contenant les sorties
+!              instantanees 
+!
+  ok_instan_omp = .false.
+  call getin('OK_instan', ok_instan_omp)
+!
+!Config Key  = ok_ade
+!Config Desc = Aerosol direct effect or not?
+!Config Def  = .false.
+!Config Help = Used in radlwsw.F
+!
+  ok_ade_omp = .false.
+  call getin('ok_ade', ok_ade_omp)
+
+!
+!Config Key  = ok_aie
+!Config Desc = Aerosol indirect effect or not?
+!Config Def  = .false.
+!Config Help = Used in nuage.F and radlwsw.F
+!
+  ok_aie_omp = .false.
+  call getin('ok_aie', ok_aie_omp)
+
+!
+!Config Key  = aerosol_couple
+!Config Desc = read aerosol in file or calcul by inca
+!Config Def  = .false.
+!Config Help = Used in physiq.F
+!
+  aerosol_couple_omp = .false.
+  CALL getin('aerosol_couple',aerosol_couple_omp)
+
+!
+!Config Key  = bl95_b0
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b0_omp = 2.
+  call getin('bl95_b0', bl95_b0_omp)
+
+!Config Key  = bl95_b1
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b1_omp = 0.2
+  call getin('bl95_b1', bl95_b1_omp)
+
+!Config Key  = freq_ISCCP
+!Config Desc = Frequence d'appel du simulateur ISCCP en secondes;
+!              par defaut 10800, i.e. 3 heures 
+!Config Def  = 10800.
+!Config Help = Used in ini_histISCCP.h
+!
+  freq_ISCCP_omp = 10800.
+  call getin('freq_ISCCP', freq_ISCCP_omp)
+!
+!Config Key  = ecrit_ISCCP
+!Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours;
+!              par defaut 1., i.e. 1 jour
+!Config Def  = 1.
+!Config Help = Used in ini_histISCCP.h
+!
+!
+  ecrit_ISCCP_omp = 1.
+  call getin('ecrit_ISCCP', ecrit_ISCCP_omp)
+!
+!Config Key  = ip_ebil_phy
+!Config Desc = Niveau de sortie pour les diags bilan d'energie 
+!Config Def  = 0
+!Config Help = 
+!               
+  ip_ebil_phy_omp = 0
+  call getin('ip_ebil_phy', ip_ebil_phy_omp)
+!
+!Config Key  = seuil_inversion
+!Config Desc = Seuil ur dTh pour le choix entre les schemas de CL
+!Config Def  = -0.1
+!Config Help = 
+!               
+  seuil_inversion_omp = -0.1
+  call getin('seuil_inversion', seuil_inversion_omp)
+
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG
+!!
+!Config Key  = R_ecc
+!Config Desc = Excentricite
+!Config Def  = 0.016715
+!Config Help = 
+!               
+!valeur AMIP II
+  R_ecc_omp = 0.016715
+  call getin('R_ecc', R_ecc_omp)
+!!
+!Config Key  = R_peri
+!Config Desc = Equinoxe
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_peri_omp = 102.7
+  call getin('R_peri', R_peri_omp)
+!!
+!Config Key  = R_incl
+!Config Desc = Inclinaison
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_incl_omp = 23.441
+  call getin('R_incl', R_incl_omp)
+!!
+!Config Key  = solaire
+!Config Desc = Constante solaire en W/m2
+!Config Def  = 1365.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  solaire_omp = 1365.
+  call getin('solaire', solaire_omp)
+!!
+!Config Key  = co2_ppm
+!Config Desc = concentration du gaz carbonique en ppmv
+!Config Def  = 348.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  co2_ppm_omp = 348.
+  call getin('co2_ppm', co2_ppm_omp)
+!!
+!Config Key  = RCO2
+!Config Desc = Concentration du CO2
+!Config Def  = co2_ppm * 1.0e-06  * 44.011/28.97
+!Config Def  = 348. * 1.0e-06  * 44.011/28.97
+!Config Help = 
+!               
+! RCO2 = 5.286789092164308E-04
+!ancienne valeur
+  RCO2_omp = co2_ppm_omp * 1.0e-06  * 44.011/28.97 ! pour co2_ppm=348.
+
+!!  call getin('RCO2', RCO2)
+!!
+!Config Key  = RCH4
+!Config Desc = Concentration du CH4
+!Config Def  = 1.65E-06* 16.043/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RCH4 = 1.65E-06* 16.043/28.97
+! RCH4 = 9.137366240938903E-07
+!
+!ancienne valeur
+! RCH4 = 1.72E-06* 16.043/28.97
+!OK call getin('RCH4', RCH4)
+  zzz = 1650.
+  call getin('CH4_ppb', zzz)
+  CH4_ppb_omp = zzz
+  RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97
+!!
+!Config Key  = RN2O
+!Config Desc = Concentration du N2O
+!Config Def  = 306.E-09* 44.013/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RN2O = 306.E-09* 44.013/28.97
+! RN2O = 4.648939592682085E-07
+!
+!ancienne valeur
+! RN2O = 310.E-09* 44.013/28.97
+!OK  call getin('RN2O', RN2O)
+  zzz=306.
+  call getin('N2O_ppb', zzz)
+  N2O_ppb_omp = zzz
+  RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97
+!!
+!Config Key  = RCFC11
+!Config Desc = Concentration du CFC11
+!Config Def  = 280.E-12* 137.3686/28.97
+!Config Help = 
+!               
+!
+!OK RCFC11 = 280.E-12* 137.3686/28.97
+  zzz = 280.
+  call getin('CFC11_ppt',zzz)
+  CFC11_ppt_omp = zzz
+  RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97
+! RCFC11 = 1.327690990680013E-09
+!OK call getin('RCFC11', RCFC11)
+!!
+!Config Key  = RCFC12
+!Config Desc = Concentration du CFC12
+!Config Def  = 484.E-12* 120.9140/28.97
+!Config Help = 
+!               
+!
+!OK RCFC12 = 484.E-12* 120.9140/28.97
+  zzz = 484.
+  call getin('CFC12_ppt',zzz)
+  CFC12_ppt_omp = zzz
+  RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97
+! RCFC12 = 2.020102726958923E-09
+!OK call getin('RCFC12', RCFC12)
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Constantes precedemment dans dyn3d/conf_gcm
+
+!Config  Key  = cycle_diurne
+!Config  Desc = Cycle ddiurne
+!Config  Def  = y
+!Config  Help = Cette option permet d'eteidre le cycle diurne.
+!Config         Peut etre util pour accelerer le code !
+       cycle_diurne_omp = .TRUE.
+       CALL getin('cycle_diurne',cycle_diurne_omp)
+
+!Config  Key  = soil_model
+!Config  Desc = Modele de sol
+!Config  Def  = y
+!Config  Help = Choix du modele de sol (Thermique ?)
+!Config         Option qui pourait un string afin de pouvoir
+!Config         plus de choix ! Ou meme une liste d'options !
+       soil_model_omp = .TRUE.
+       CALL getin('soil_model',soil_model_omp)
+
+!Config  Key  = new_oliq
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = y
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       new_oliq_omp = .TRUE.
+       CALL getin('new_oliq',new_oliq_omp)
+
+!Config  Key  = ok_orodr
+!Config  Desc = Orodr ???
+!Config  Def  = y
+!Config  Help = Y en a pas comprendre !
+!Config         
+       ok_orodr_omp = .TRUE.
+       CALL getin('ok_orodr',ok_orodr_omp)
+
+!Config  Key  =  ok_orolf
+!Config  Desc = Orolf ??
+!Config  Def  = y
+!Config  Help = Connais pas !
+       ok_orolf_omp = .TRUE.
+       CALL getin('ok_orolf_omp', ok_orolf_omp)
+
+!Config  Key  = ok_limitvrai
+!Config  Desc = Force la lecture de la bonne annee
+!Config  Def  = n
+!Config  Help = On peut forcer le modele a lire le
+!Config         fichier SST de la bonne annee. C'est une tres bonne
+!Config         idee, pourquoi ne pas mettre toujours a y ???
+       ok_limitvrai_omp = .FALSE.
+       CALL getin('ok_limitvrai',ok_limitvrai_omp)
+
+!Config  Key  = nbapp_rad
+!Config  Desc = Frequence d'appel au rayonnement
+!Config  Def  = 12
+!Config  Help = Nombre  d'appels des routines de rayonnements
+!Config         par jour.
+       nbapp_rad_omp = 12
+       CALL getin('nbapp_rad',nbapp_rad_omp)
+
+!Config  Key  = iflag_con
+!Config  Desc = Flag de convection
+!Config  Def  = 2
+!Config  Help = Flag  pour la convection les options suivantes existent :
+!Config         1 pour LMD,
+!Config         2 pour Tiedtke,
+!Config         3 pour CCM(NCAR)  
+       iflag_con_omp = 2
+       CALL getin('iflag_con',iflag_con_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END
+!!
+!! KE
+!
+
+!Config key  = cvl_corr
+!Config Desc = Facteur multiplication des precip convectives dans KE
+!Config Def  = 1.00
+!Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire
+  cvl_corr_omp = 1.00
+  CALL getin('cvl_corr', cvl_corr_omp)
+
+
+!Config Key  = epmax
+!Config Desc = Efficacite precip
+!Config Def  = 0.993
+!Config Help = 
+!
+  epmax_omp = .993
+  call getin('epmax', epmax_omp)
+!
+!Config Key  = ok_adj_ema
+!Config Desc =  
+!Config Def  = false
+!Config Help = 
+!
+  ok_adj_ema_omp = .false.
+  call getin('ok_adj_ema',ok_adj_ema_omp)
+!
+!Config Key  = iflag_clw
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clw_omp = 0
+  call getin('iflag_clw',iflag_clw_omp)
+!
+!Config Key  = cld_lc_lsc 
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_lsc_omp = 2.6e-4
+  call getin('cld_lc_lsc',cld_lc_lsc_omp)
+!
+!Config Key  = cld_lc_con
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_con_omp = 2.6e-4
+  call getin('cld_lc_con',cld_lc_con_omp)
+!
+!Config Key  = cld_tau_lsc
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_lsc_omp = 3600.
+  call getin('cld_tau_lsc',cld_tau_lsc_omp)
+!
+!Config Key  = cld_tau_con
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_con_omp = 3600.
+  call getin('cld_tau_con',cld_tau_con_omp)
+!
+!Config Key  = ffallv_lsc
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_lsc_omp = 1.
+  call getin('ffallv_lsc',ffallv_lsc_omp)
+!
+!Config Key  = ffallv_con
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_con_omp = 1.
+  call getin('ffallv_con',ffallv_con_omp)
+!
+!Config Key  = coef_eva
+!Config Desc =  
+!Config Def  = 2.e-5
+!Config Help = 
+!
+  coef_eva_omp = 2.e-5
+  call getin('coef_eva',coef_eva_omp)
+!
+!Config Key  = reevap_ice
+!Config Desc =  
+!Config Def  = .false.
+!Config Help = 
+!
+  reevap_ice_omp = .false.
+  call getin('reevap_ice',reevap_ice_omp)
+
+!Config Key  = iflag_ratqs
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_ratqs_omp = 1
+  call getin('iflag_ratqs',iflag_ratqs_omp)
+
+!
+!Config Key  = iflag_radia 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_radia_omp = 1
+  call getin('iflag_radia',iflag_radia_omp)
+
+!Config Key  = iflag_cldcon 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_cldcon_omp = 1
+  call getin('iflag_cldcon',iflag_cldcon_omp)
+
+!
+!Config Key  = iflag_pdf 
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_pdf_omp = 0
+  call getin('iflag_pdf',iflag_pdf_omp)
+!
+!Config Key  = fact_cldcon
+!Config Desc =  
+!Config Def  = 0.375
+!Config Help = 
+!
+  fact_cldcon_omp = 0.375
+  call getin('fact_cldcon',fact_cldcon_omp)
+
+!
+!Config Key  = facttemps
+!Config Desc =  
+!Config Def  = 1.e-4
+!Config Help = 
+!
+  facttemps_omp = 1.e-4
+  call getin('facttemps',facttemps_omp)
+
+!
+!Config Key  = ok_newmicro
+!Config Desc =  
+!Config Def  = .true.
+!Config Help = 
+!
+  ok_newmicro_omp = .true.
+  call getin('ok_newmicro',ok_newmicro_omp)
+!
+!Config Key  = ratqsbas
+!Config Desc =  
+!Config Def  = 0.01
+!Config Help = 
+!
+  ratqsbas_omp = 0.01
+  call getin('ratqsbas',ratqsbas_omp)
+!
+!Config Key  = ratqshaut
+!Config Desc =  
+!Config Def  = 0.3
+!Config Help = 
+!
+  ratqshaut_omp = 0.3
+  call getin('ratqshaut',ratqshaut_omp)
+
+!
+!-----------------------------------------------------------------------
+! Longitude solaire pour le calcul de l'ensoleillement en degre
+! si on veut imposer la saison. Sinon, solarlong0=-999.999
+!Config Key  = solarlong0
+!Config Desc =  
+!Config Def  = -999.999 
+!Config Help = 
+!
+  solarlong0_omp = -999.999
+  call getin('solarlong0',solarlong0_omp)
+!
+!-----------------------------------------------------------------------
+!  Valeur imposee de l'humidite du sol pour le modele bucket.
+!Config Key  = qsol0
+!Config Desc =  
+!Config Def  = -1.
+!Config Help = 
+!
+  qsol0_omp = -1.
+  call getin('qsol0',qsol0_omp)
+!
+!-----------------------------------------------------------------------
+!
+!Config Key  = inertie_ice
+!Config Desc =  
+!Config Def  = 2000.
+!Config Help = 
+!
+  inertie_ice_omp = 2000.
+  call getin('inertie_ice',inertie_ice_omp)
+!
+!Config Key  = inertie_sno
+!Config Desc =  
+!Config Def  = 2000.
+!Config Help = 
+!
+  inertie_sno_omp = 2000.
+  call getin('inertie_sno',inertie_sno_omp)
+!
+!Config Key  = inertie_sol
+!Config Desc =  
+!Config Def  = 2000.
+!Config Help = 
+!
+  inertie_sol_omp = 2000.
+  call getin('inertie_sol',inertie_sol_omp)
+
+!
+!Config Key  = rad_froid
+!Config Desc =  
+!Config Def  = 35.0
+!Config Help = 
+!
+  rad_froid_omp = 35.0
+  call getin('rad_froid',rad_froid_omp)
+
+!
+!Config Key  = rad_chau1
+!Config Desc =  
+!Config Def  = 13.0
+!Config Help = 
+!
+  rad_chau1_omp = 13.0
+  call getin('rad_chau1',rad_chau1_omp)
+
+!
+!Config Key  = rad_chau2
+!Config Desc =  
+!Config Def  = 9.0
+!Config Help = 
+!
+  rad_chau2_omp = 9.0
+  call getin('rad_chau2',rad_chau2_omp)
+
+!
+!Config Key  = top_height
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  top_height_omp = 3
+  call getin('top_height',top_height_omp)
+
+!
+!Config Key  = overlap
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  overlap_omp = 3
+  call getin('overlap',overlap_omp)
+
+
+!
+!
+!Config Key  = cdmmax
+!Config Desc =
+!Config Def  = 1.3E-3
+!Config Help =
+!
+  cdmmax_omp = 1.3E-3
+  call getin('cdmmax',cdmmax_omp)
+
+!
+!Config Key  = cdhmax
+!Config Desc =
+!Config Def  = 1.1E-3
+!Config Help =
+!
+  cdhmax_omp = 1.1E-3
+  call getin('cdhmax',cdhmax_omp)
+
+!261103
+!
+!Config Key  = ksta
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_omp = 1.0e-10
+  call getin('ksta',ksta_omp)
+
+!
+!Config Key  = ksta_ter
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_ter_omp = 1.0e-10
+  call getin('ksta_ter',ksta_ter_omp)
+
+!
+!Config Key  = ok_kzmin
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+  ok_kzmin_omp = .true.
+  call getin('ok_kzmin',ok_kzmin_omp)
+
+!
+!Config Key  = fmagic
+!Config Desc = additionnal multiplicator factor used for albedo
+!Config Def  = 1.
+!Config Help = additionnal multiplicator factor used in albedo.F
+!
+  fmagic_omp = 1.
+  call getin('fmagic',fmagic_omp)
+
+!
+!Config Key  = pmagic
+!Config Desc = additional factor used for albedo
+!Config Def  = 0.
+!Config Help = additional factor used in albedo.F
+!
+  pmagic_omp = 0.
+  call getin('pmagic',pmagic_omp)
+
+
+!Config Key = ok_lic_melt
+!Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau
+!Config Def  = .false.
+!Config Help = mettre a .false. pour assurer la conservation en eau
+  ok_lic_melt_omp = .false.
+  call getin('ok_lic_melt', ok_lic_melt_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Config Key  = iflag_pbl
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_pbl_omp = 1
+  call getin('iflag_pbl',iflag_pbl_omp)
+!
+!Config Key  = iflag_thermals
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_thermals_omp = 0
+  call getin('iflag_thermals',iflag_thermals_omp)
+!
+!
+!Config Key  = nsplit_thermals
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  nsplit_thermals_omp = 1
+  call getin('nsplit_thermals',nsplit_thermals_omp)
+
+!Config Key  = tau_thermals
+!Config Desc =
+!Config Def  = 0.
+!Config Help =
+!
+  tau_thermals_omp = 0.
+  call getin('tau_thermals',tau_thermals_omp)
+
+!
+!Config Key  = iflag_coupl
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_coupl = 0
+  call getin('iflag_coupl',iflag_coupl_omp)
+
+!
+!Config Key  = iflag_clos
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clos = 1
+  call getin('iflag_clos',iflag_clos_omp)
+!
+!Config Key  = iflag_cvl_sigd
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_cvl_sigd = 0
+  call getin('iflag_cvl_sigd',iflag_cvl_sigd_omp)
+
+!Config Key  = iflag_wake
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_wake = 0
+  call getin('iflag_wake',iflag_wake_omp)
+
+!
+!Config Key  = lev_histhf
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histhf_omp = 1
+  call getin('lev_histhf',lev_histhf_omp)
+
+!
+!Config Key  = lev_histday
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histday_omp = 1
+  call getin('lev_histday',lev_histday_omp)
+
+!
+!Config Key  = lev_histmth
+!Config Desc =
+!Config Def  = 2
+!Config Help =
+!
+  lev_histmth_omp = 2
+  call getin('lev_histmth',lev_histmth_omp)
+
+  !
+!Config Key  = type_run
+!Config Desc =
+!Config Def  = 'AMIP'/'CFMIP'  ou 'CLIM'/'ENSP'
+!Config Help =
+!
+  type_run_omp = 'AMIP'
+  call getin('type_run',type_run_omp)
+
+!
+!Config Key  = ok_isccp
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+! ok_isccp = .true.
+  ok_isccp_omp = .false.
+  call getin('ok_isccp',ok_isccp_omp)
+
+!
+! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone 
+! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc"
+!
+!Config Key  = lonmin_ins
+!Config Desc = 100.  
+!Config Def  = longitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   lonmin_ins_omp = 100.
+   call getin('lonmin_ins',lonmin_ins_omp)
+!
+!Config Key  = lonmax_ins
+!Config Desc = 130. 
+!Config Def  = longitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   lonmax_ins_omp = 130.
+   call getin('lonmax_ins',lonmax_ins_omp)
+!
+!Config Key  = latmin_ins
+!Config Desc = -20.  
+!Config Def  = latitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   latmin_ins_omp = -20.
+   call getin('latmin_ins',latmin_ins_omp)
+!
+!Config Key  = latmax_ins
+!Config Desc = 20. 
+!Config Def  = latitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   latmax_ins_omp = 20.
+   call getin('latmax_ins',latmax_ins_omp)
+!
+!Config Key  = ecrit_hf
+!Config Desc =
+!Config Def  = 1./8. !toutes les 3h
+!Config Help =
+!
+  ecrit_hf_omp = 1./8.
+  call getin('ecrit_hf',ecrit_hf_omp)
+!
+!Config Key  = ecrit_day
+!Config Desc =
+!Config Def  = 1.0 !tous les jours
+!Config Help = nombre de jours pour ecriture fichier histday.nc
+!
+  ecrit_day_omp = 1.0
+  call getin('ecrit_day',ecrit_day_omp)
+!
+!Config Key  = ecrit_mth
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_mth_omp = 30.
+  call getin('ecrit_mth',ecrit_mth_omp)
+!
+!Config Key  = ecrit_tra
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_tra_omp = 30.
+  call getin('ecrit_tra',ecrit_tra_omp)
+!
+!Config Key  = ecrit_reg
+!Config Desc =
+!Config Def  = 0.25  !4 fois par jour
+!Config Help =
+!
+  ecrit_reg_omp = 0.25   !4 fois par jour
+  call getin('ecrit_reg',ecrit_reg_omp)
+!
+!
+!
+!Config Key  = ok_slab_sicOBS
+!Config Desc =
+!Config Def  = .true.
+!Config Help = Pour faire tourner le slab avec fraction 
+!              de glace de mer Observee
+!
+  ok_slab_sicOBS_omp = .true.
+  call getin('ok_slab_sicOBS', ok_slab_sicOBS_omp)
+!
+!
+! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+!
+!Config Key  = supcrit1
+!Config Desc =
+!Config Def  = .540
+!Config Help =
+!
+  supcrit1_omp = .540
+  call getin('supcrit1',supcrit1_omp)
+
+!
+!Config Key  = supcrit2
+!Config Desc =
+!Config Def  = .600
+!Config Help =
+!
+  supcrit2_omp = .600
+  call getin('supcrit2',supcrit2_omp)
+
+!
+! PARAMETERS FOR THE MIXING DISTRIBUTION
+!
+!
+!Config Key  = iflag_mix
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_mix_omp = 1
+  call getin('iflag_mix',iflag_mix_omp)
+
+!
+!Config Key  = scut
+!Config Desc =
+!Config Def  = 0.95
+!Config Help =
+!
+  scut_omp = 0.95
+  call getin('scut',scut_omp)
+
+!
+!Config Key  = qqa1
+!Config Desc =
+!Config Def  = 1.0
+!Config Help =
+!
+  qqa1_omp = 1.0
+  call getin('qqa1',qqa1_omp)
+
+!
+!Config Key  = qqa2
+!Config Desc =
+!Config Def  = 0.0
+!Config Help =
+!
+  qqa2_omp = 0.0
+  call getin('qqa2',qqa2_omp)
+
+!
+!Config Key  = gammas
+!Config Desc =
+!Config Def  = 0.05
+!Config Help =
+!
+  gammas_omp = 0.05
+  call getin('gammas',gammas_omp)
+
+!
+!Config Key  = Fmax
+!Config Desc =
+!Config Def  = 0.65
+!Config Help =
+!
+  Fmax_omp = 0.65
+  call getin('Fmax',Fmax_omp)
+
+!
+!Config Key  = alphas  
+!Config Desc =
+!Config Def  = -5.
+!Config Help =
+!
+  alphas_omp = -5.
+  call getin('alphas',alphas_omp)
+
+
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+    R_ecc = R_ecc_omp
+    R_peri = R_peri_omp
+    R_incl = R_incl_omp
+    solaire = solaire_omp
+    co2_ppm = co2_ppm_omp
+    RCO2 = RCO2_omp
+    CH4_ppb = CH4_ppb_omp
+    RCH4 = RCH4_omp
+    N2O_ppb = N2O_ppb_omp
+    RN2O = RN2O_omp
+    CFC11_ppt = CFC11_ppt_omp
+    RCFC11 = RCFC11_omp
+    CFC12_ppt = CFC12_ppt_omp
+    RCFC12 = RCFC12_omp
+
+    cycle_diurne = cycle_diurne_omp
+    soil_model = soil_model_omp
+    new_oliq = new_oliq_omp
+    ok_orodr = ok_orodr_omp
+    ok_orolf = ok_orolf_omp
+    ok_limitvrai = ok_limitvrai_omp
+    nbapp_rad = nbapp_rad_omp
+    iflag_con = iflag_con_omp
+
+    epmax = epmax_omp
+    ok_adj_ema = ok_adj_ema_omp
+    iflag_clw = iflag_clw_omp
+    cld_lc_lsc = cld_lc_lsc_omp
+    cld_lc_con = cld_lc_con_omp
+    cld_tau_lsc = cld_tau_lsc_omp
+    cld_tau_con = cld_tau_con_omp
+    ffallv_lsc = ffallv_lsc_omp
+    ffallv_con = ffallv_con_omp
+    coef_eva = coef_eva_omp
+    reevap_ice = reevap_ice_omp
+    iflag_pdf = iflag_pdf_omp
+    solarlong0 = solarlong0_omp
+    qsol0 = qsol0_omp
+    inertie_sol = inertie_sol_omp
+    inertie_ice = inertie_ice_omp
+    inertie_sno = inertie_sno_omp
+    rad_froid = rad_froid_omp
+    rad_chau1 = rad_chau1_omp
+    rad_chau2 = rad_chau2_omp
+    top_height = top_height_omp
+    overlap = overlap_omp
+    cdmmax = cdmmax_omp
+    cdhmax = cdhmax_omp
+    ksta = ksta_omp
+    ksta_ter = ksta_ter_omp
+    ok_kzmin = ok_kzmin_omp
+    fmagic = fmagic_omp
+    pmagic = pmagic_omp
+    iflag_pbl = iflag_pbl_omp
+    lev_histhf = lev_histhf_omp
+    lev_histday = lev_histday_omp
+    lev_histmth = lev_histmth_omp
+
+    ocean = ocean_omp
+    ok_veget = ok_veget_omp
+    ok_newmicro = ok_newmicro_omp
+    ok_journe = ok_journe_omp
+    ok_hf = ok_hf_omp
+    ok_mensuel = ok_mensuel_omp
+    ok_instan = ok_instan_omp
+    freq_ISCCP = freq_ISCCP_omp
+    ecrit_ISCCP = ecrit_ISCCP_omp
+    ok_ade = ok_ade_omp
+    ok_aie = ok_aie_omp
+    aerosol_couple = aerosol_couple_omp
+    bl95_b0 = bl95_b0_omp
+    bl95_b1 = bl95_b1_omp
+    fact_cldcon = fact_cldcon_omp
+    facttemps = facttemps_omp
+    ratqsbas = ratqsbas_omp
+    ratqshaut = ratqshaut_omp
+    iflag_radia = iflag_radia_omp
+    iflag_cldcon = iflag_cldcon_omp
+    iflag_ratqs = iflag_ratqs_omp
+    ip_ebil_phy = ip_ebil_phy_omp
+    iflag_thermals = iflag_thermals_omp
+    nsplit_thermals = nsplit_thermals_omp
+    tau_thermals = tau_thermals_omp
+    iflag_coupl = iflag_coupl_omp
+    iflag_clos = iflag_clos_omp
+    iflag_wake = iflag_wake_omp
+    iflag_cvl_sigd = iflag_cvl_sigd_omp
+    type_run = type_run_omp
+    ok_isccp = ok_isccp_omp
+    seuil_inversion=seuil_inversion_omp
+    lonmin_ins = lonmin_ins_omp
+    lonmax_ins = lonmax_ins_omp
+    latmin_ins = latmin_ins_omp
+    latmax_ins = latmax_ins_omp
+    ecrit_hf   = ecrit_hf_omp
+    ecrit_day = ecrit_day_omp
+    ecrit_mth = ecrit_mth_omp
+    ecrit_tra = ecrit_tra_omp
+    ecrit_reg = ecrit_reg_omp
+    ok_slab_sicOBS = ok_slab_sicOBS_omp
+    cvl_corr = cvl_corr_omp
+    ok_lic_melt = ok_lic_melt_omp
+    supcrit1 = supcrit1_omp
+    supcrit2 = supcrit2_omp
+    iflag_mix = iflag_mix_omp
+    scut = scut_omp
+    qqa1 = qqa1_omp
+    qqa2 = qqa2_omp
+    gammas = gammas_omp
+    Fmax = Fmax_omp
+    alphas = alphas_omp
+
+!$OMP MASTER
+
+  write(numout,*)' ##############################################'
+  write(numout,*)' Configuration des parametres de la physique: '
+  write(numout,*)' Config ocean = ', ocean
+  write(numout,*)' Config veget = ', ok_veget
+  write(numout,*)' Sortie journaliere = ', ok_journe
+  write(numout,*)' Sortie haute frequence = ', ok_hf
+  write(numout,*)' Sortie mensuelle = ', ok_mensuel
+  write(numout,*)' Sortie instantanee = ', ok_instan
+  write(numout,*)' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP
+  write(numout,*)' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP
+  write(numout,*)' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy
+  write(numout,*)' Excentricite = ',R_ecc
+  write(numout,*)' Equinoxe = ',R_peri
+  write(numout,*)' Inclinaison =',R_incl
+  write(numout,*)' Constante solaire =',solaire
+  write(numout,*)' co2_ppm =',co2_ppm
+  write(numout,*)' RCO2 = ',RCO2
+  write(numout,*)' CH4_ppb =',CH4_ppb,' RCH4 = ',RCH4
+  write(numout,*)' N2O_ppb =',N2O_ppb,' RN2O =  ',RN2O
+  write(numout,*)' CFC11_ppt=',CFC11_ppt,' RCFC11 =  ',RCFC11
+  write(numout,*)' CFC12_ppt=',CFC12_ppt,' RCFC12 =  ',RCFC12
+  write(numout,*)' cvl_corr=', cvl_corr
+  write(numout,*)'ok_lic_melt=', ok_lic_melt
+  write(numout,*)'cycle_diurne=',cycle_diurne
+  write(numout,*)'soil_model=',soil_model
+  write(numout,*)'new_oliq=',new_oliq
+  write(numout,*)'ok_orodr=',ok_orodr
+  write(numout,*)'ok_orolf=',ok_orolf
+  write(numout,*)'ok_limitvrai=',ok_limitvrai
+  write(numout,*)'nbapp_rad=',nbapp_rad
+  write(numout,*)'iflag_con=',iflag_con
+  write(numout,*)' epmax = ', epmax
+  write(numout,*)' ok_adj_ema = ', ok_adj_ema
+  write(numout,*)' iflag_clw = ', iflag_clw
+  write(numout,*)' cld_lc_lsc = ', cld_lc_lsc
+  write(numout,*)' cld_lc_con = ', cld_lc_con
+  write(numout,*)' cld_tau_lsc = ', cld_tau_lsc
+  write(numout,*)' cld_tau_con = ', cld_tau_con
+  write(numout,*)' ffallv_lsc = ', ffallv_lsc
+  write(numout,*)' ffallv_con = ', ffallv_con
+  write(numout,*)' coef_eva = ', coef_eva
+  write(numout,*)' reevap_ice = ', reevap_ice
+  write(numout,*)' iflag_pdf = ', iflag_pdf
+  write(numout,*)' iflag_cldcon = ', iflag_cldcon
+  write(numout,*)' iflag_radia = ', iflag_radia
+  write(numout,*)' iflag_ratqs = ', iflag_ratqs
+  write(numout,*)' seuil_inversion = ', seuil_inversion
+  write(numout,*)' fact_cldcon = ', fact_cldcon
+  write(numout,*)' facttemps = ', facttemps
+  write(numout,*)' ok_newmicro = ',ok_newmicro 
+  write(numout,*)' ratqsbas = ',ratqsbas 
+  write(numout,*)' ratqshaut = ',ratqshaut 
+  write(numout,*)' top_height = ',top_height 
+  write(numout,*)' overlap = ',overlap 
+  write(numout,*)' cdmmax = ',cdmmax 
+  write(numout,*)' cdhmax = ',cdhmax 
+  write(numout,*)' ksta = ',ksta 
+  write(numout,*)' ksta_ter = ',ksta_ter 
+  write(numout,*)' ok_kzmin = ',ok_kzmin 
+  write(numout,*)' fmagic = ',fmagic
+  write(numout,*)' pmagic = ',pmagic
+  write(numout,*)' ok_ade = ',ok_ade
+  write(numout,*)' ok_aie = ',ok_aie
+  write(numout,*)' aerosol_couple = ', aerosol_couple
+  write(numout,*)' bl95_b0 = ',bl95_b0
+  write(numout,*)' bl95_b1 = ',bl95_b1
+  write(numout,*)' lev_histhf = ',lev_histhf 
+  write(numout,*)' lev_histday = ',lev_histday 
+  write(numout,*)' lev_histmth = ',lev_histmth 
+  write(numout,*)' iflag_pbl = ', iflag_pbl
+  write(numout,*)' iflag_thermals = ', iflag_thermals
+  write(numout,*)' type_run = ',type_run 
+  write(numout,*)' ok_isccp = ',ok_isccp 
+  WRITE(numout,*)' solarlong0 = ', solarlong0
+  write(numout,*)' qsol0 = ', qsol0
+  write(numout,*)' inertie_sol = ', inertie_sol
+  write(numout,*)' inertie_ice = ', inertie_ice
+  write(numout,*)' inertie_sno = ', inertie_sno
+  write(numout,*)' supcrit1 = ', supcrit1
+  write(numout,*)' supcrit2 = ', supcrit2
+  write(numout,*)' iflag_mix = ', iflag_mix
+  write(numout,*)' scut = ', scut
+  write(numout,*)' qqa1 = ', qqa1
+  write(numout,*)' qqa2 = ', qqa2
+  write(numout,*)' gammas = ', gammas
+  write(numout,*)' Fmax = ', Fmax
+  write(numout,*)' alphas = ', alphas
+
+  write(numout,*)' lonmin lonmax latmin latmax bilKP_ins =',&
+ & lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+  write(numout,*)' ecrit_ hf, day, mth, reg, tra, ISCCP',&
+ & ecrit_hf, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP
+
+!$OMP END MASTER
+
+  return
+  
+  end subroutine conf_phys
+
+!
+!#################################################################
+!
+
+   subroutine conf_interface(tau_calv)
+
+   use IOIPSL
+   implicit none
+
+! Configuration de l'interace atm/surf
+!
+! tau_calv:    temps de relaxation pour la fonte des glaciers
+
+  REAL          :: tau_calv
+  REAL,SAVE     :: tau_calv_omp
+
+! Local
+  integer              :: numout = 6
+!
+!Config Key  = tau_calv
+!Config Desc = temps de relaxation pour fonte des glaciers en jours
+!Config Def  = 1 an 
+!Config Help = 
+!
+  tau_calv_omp = 360.*10.
+!$OMP MASTER
+  call getin('tau_calv',tau_calv_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  tau_calv=tau_calv_omp
+  
+!$OMP MASTER
+  write(numout,*)' ##############################################'
+  WRITE(numout,*)' Configuration de l''interface atm/surfaces  : '
+  WRITE(numout,*)' tau_calv = ',tau_calv
+!$OMP END MASTER
+
+  return
+
+  end subroutine conf_interface
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conflx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conflx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conflx.F	(revision 984)
@@ -0,0 +1,1676 @@
+!
+! $Header$
+!
+      SUBROUTINE conflx (dtime,pres_h,pres_f,
+     e                   t, q, con_t, con_q, pqhfl, w,
+     s                   d_t, d_q, rain, snow,
+     s                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s                   kcbot, kctop, kdtop, pmflxr, pmflxs)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+c Objet: Schema flux de masse pour la convection 
+c        (schema de Tiedtke avec qqs modifications mineures)
+c Dec.97: Prise en compte des modifications introduites par
+c         Olivier Boucher et Alexandre Armengaud pour melange
+c         et lessivage des traceurs passifs.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c Entree:
+      REAL dtime            ! pas d'integration (s)
+      REAL pres_h(klon,klev+1) ! pression half-level (Pa)
+      REAL pres_f(klon,klev)! pression full-level (Pa)
+      REAL t(klon,klev)     ! temperature (K)
+      REAL q(klon,klev)     ! humidite specifique (g/g)
+      REAL w(klon,klev)     ! vitesse verticale (Pa/s)
+      REAL con_t(klon,klev) ! convergence de temperature (K/s)
+      REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s)
+      REAL pqhfl(klon)      ! evaporation (negative vers haut) mm/s
+c Sortie:
+      REAL d_t(klon,klev)   ! incrementation de temperature
+      REAL d_q(klon,klev)   ! incrementation d'humidite
+      REAL pmfu(klon,klev)  ! flux masse (kg/m2/s) panache ascendant
+      REAL pmfd(klon,klev)  ! flux masse (kg/m2/s) panache descendant
+      REAL pen_u(klon,klev)
+      REAL pen_d(klon,klev)
+      REAL pde_u(klon,klev)
+      REAL pde_d(klon,klev)
+      REAL rain(klon)       ! pluie (mm/s)
+      REAL snow(klon)       ! neige (mm/s)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER kcbot(klon)  ! niveau du bas de la convection
+      INTEGER kctop(klon)  ! niveau du haut de la convection
+      INTEGER kdtop(klon)  ! niveau du haut des downdrafts
+c Local:
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pqs(klon,klev)
+      REAL pvervel(klon,klev)
+      LOGICAL land(klon)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL paprsf(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL zcvgq(klon,klev)
+      REAL zcvgt(klon,klev)
+cAA
+      REAL zmfu(klon,klev) 
+      REAL zmfd(klon,klev)
+      REAL zen_u(klon,klev)
+      REAL zen_d(klon,klev)
+      REAL zde_u(klon,klev)
+      REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
+cAA
+
+c
+      INTEGER i, k
+      REAL zdelta, zqsat
+c
+#include "FCTTRE.h"
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kcbot(i) = 0
+         kctop(i) = 0
+         kdtop(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         pmfu(i,k) = 0.0
+         pmfd(i,k) = 0.0
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+         zmfu(i,k) = 0.0
+         zmfd(i,k) = 0.0
+         zen_u(i,k) = 0.0
+         zde_u(i,k) = 0.0
+         zen_d(i,k) = 0.0
+         zde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c calculer la nature du sol (pour l'instant, ocean partout)
+      DO i = 1, klon
+         land(i) = .FALSE.
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         paprsf(i,k) = pres_f(i,klev-k+1)
+         paprs(i,k) = pres_h(i,klev+1-k+1)
+         pvervel(i,k) = w(i,klev+1-k)
+         zcvgt(i,k) = con_t(i,klev-k+1)
+         zcvgq(i,k) = con_q(i,klev-k+1)
+c
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k)))
+         zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k)
+         zqsat=MIN(0.5,zqsat)
+         zqsat=zqsat/(1.-RETV  *zqsat)
+         pqs(i,k) = zqsat
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pres_h(i,1)
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                   / (0.5*(paprs(i,klev+1)+paprsf(i,klev)))
+     .                   * (paprs(i,klev+1)-paprsf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1)
+     .              + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1)
+     .                   * (paprsf(i,k+1)-paprsf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL flxmain(dtime, pt, pq, pqs, pqhfl,
+     .             paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel,
+     .             rain, snow, kcbot, kctop, kdtop,
+     .             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     .             d_t_bis, d_q_bis, zmflxr, zmflxs)
+C
+cAA--------------------------------------------------------
+cAA rem : De la meme facon que l'on effectue le reindicage 
+cAA       pour la temperature t et le champ q 
+cAA       on reindice les flux necessaires a la convection 
+cAA       des traceurs
+cAA--------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = dtime*d_q_bis(i,k)
+         d_t(i,klev+1-k) = dtime*d_t_bis(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         pmfu(i,1)= 0.
+         pmfd(i,1)= 0.
+         pen_d(i,1)= 0.
+         pde_d(i,1)= 0.
+      ENDDO
+     
+      DO k = 2, klev
+      DO i = 1, klon
+         pmfu(i,klev+2-k)= zmfu(i,k)
+         pmfd(i,klev+2-k)= zmfd(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pen_u(i,klev+1-k)=  zen_u(i,k)
+         pde_u(i,klev+1-k)=  zde_u(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+         pen_d(i,klev+1-k)= -zen_d(i,k+1)
+         pde_d(i,klev+1-k)= -zde_d(i,k+1)
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,klev+2-k)= zmflxr(i,k)
+         pmflxs(i,klev+2-k)= zmflxs(i,k)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c--------------------------------------------------------------------
+      SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph,
+     .                   pgeo, ldland, ptte, pqte, pvervel,
+     .                   prsfc, pssfc, kcbot, kctop, kdtop,
+c     *                   ldcum, ktype,
+     .                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .                   dt_con, dq_con, pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C     ------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     ----------------------------------------------------------------
+      REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev)
+      REAL ptte(klon,klev)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev)
+      REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1)
+      REAL pqhfl(klon)
+c
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev)
+      REAL prsfc(klon), pssfc(klon)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+c
+      REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev)
+      REAL zgeoh(klon,klev)
+      REAL zmfub(klon), zmfub1(klon)
+      REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev)
+      REAL zdmfup(klon,klev), zdpmel(klon,klev)
+      REAL zentr(klon), zhcbase(klon)
+      REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+      REAL zrfl(klon)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER  ilab(klon,klev), ictop0(klon)
+      LOGICAL  llo1
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+      REAL zmfmax, zdh
+      REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+      REAL zhhat, zpbmpt, zgam, zeps, zfac
+      INTEGER i, k, ikb, itopm2, kcum
+c
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL pen_d(klon,klev), pde_d(klon,klev)
+c
+      REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev)
+      REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev)
+      INTEGER kdtop(klon)
+      LOGICAL lddraf(klon)
+C---------------------------------------------------------------------
+      LOGICAL firstcal
+      SAVE firstcal
+      DATA firstcal / .TRUE. /
+c$OMP THREADPRIVATE(firstcal)
+C---------------------------------------------------------------------
+      IF (firstcal) THEN
+         CALL flxsetup
+         firstcal = .FALSE.
+      ENDIF
+C---------------------------------------------------------------------
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         dt_con(i,k) = 0.0
+         dq_con(i,k) = 0.0
+      ENDDO
+      ENDDO
+c----------------------------------------------------------------------
+c initialiser les variables et faire l'interpolation verticale
+c----------------------------------------------------------------------
+      CALL flxini(pten, pqen, pqsen, pgeo,
+     .     paph, zgeoh, ztenh, zqenh, zqsenh,
+     .     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp,
+     .     pmfu, zmfus, zmfuq, zdmfup,
+     .     zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+c---------------------------------------------------------------------
+c determiner les valeurs au niveau de base de la tour convective
+c---------------------------------------------------------------------
+      CALL flxbase(ztenh, zqenh, zgeoh, paph,
+     *            ptu, pqu, plu, ldcum, kcbot, ilab)
+c---------------------------------------------------------------------
+c calculer la convergence totale de l'humidite et celle en provenance
+c de la couche limite, plus precisement, la convergence integree entre
+c le sol et la base de la convection. Cette derniere convergence est
+c comparee avec l'evaporation obtenue dans la couche limite pour
+c determiner le type de la convection
+c---------------------------------------------------------------------
+      k=1
+      DO i = 1, klon
+         zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k))
+         zdhpbl(i) = 0.0
+         zdqpbl(i) = 0.0
+      ENDDO
+c
+      DO k=2,klev
+      DO i = 1, klon
+          zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+          IF (k.GE.kcbot(i)) THEN
+             zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+             zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k))
+     .                          *(paph(i,k+1)-paph(i,k))
+          ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         ktype(i) = 2
+         if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1
+ccc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+      ENDDO
+c
+c---------------------------------------------------------------------
+c determiner le flux de masse entrant a travers la base.
+c on ignore, pour l'instant, l'effet du panache descendant
+c---------------------------------------------------------------------
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb)
+         zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN
+            zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub(i) = 0.01
+            ldcum(i)=.FALSE.
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh
+         ENDIF
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         zmfub(i) = MIN(zmfub(i),zmfmax)
+         zentr(i) = ENTRSCV
+         IF (ktype(i).EQ.1) zentr(i) = ENTRPEN
+      ENDDO
+C-----------------------------------------------------------------------
+C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+C-----------------------------------------------------------------------
+c (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+c     considerer l'entrainement ni le detrainement du panache, sachant
+c     ces derniers peuvent abaisser la hauteur theorique.
+c
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb)
+         ictop0(i)=kcbot(i)-1
+      ENDDO
+c
+      zalvdcp=RLVTT/RCPD
+      DO k=klev-1,3,-1
+      DO i = 1, klon
+         zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k)
+         zgam=R5LES*zalvdcp*zqsenh(i,k)/
+     .        ((1.-RETV  *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2)
+         zzz=RCPD*ztenh(i,k)*0.608
+         zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)*
+     .               MAX(zqsenh(i,k)-zqenh(i,k),0.)
+         IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k
+      ENDDO
+      ENDDO
+c
+c (B) calculer le panache ascendant
+c
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+      IF (kcum.EQ.0) GO TO 1000
+C
+C verifier l'epaisseur de la convection et changer eventuellement
+c le taux d'entrainement/detrainement
+C
+      DO i = 1, klon
+         zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i))
+         IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2
+         IF(ldcum(i)) ictop0(i)=kctop(i)
+         IF(ktype(i).EQ.2) zentr(i)=ENTRSCV
+      ENDDO
+c
+      IF (lmfdd) THEN  ! si l'on considere le panache descendant
+c
+c calculer la precipitation issue du panache ascendant pour 
+c determiner l'existence du panache descendant dans la convection
+      DO i = 1, klon
+         zrfl(i)=zdmfup(i,1)
+      ENDDO
+      DO k=2,klev
+      DO i = 1, klon
+         zrfl(i)=zrfl(i)+zdmfup(i,k)
+      ENDDO
+      ENDDO
+c
+c determiner le LFS (level of free sinking: niveau de plonge libre)
+      CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu,
+     *     ldcum,    kcbot,    kctop,    zmfub,    zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     kdtop,    lddraf)
+c
+c calculer le panache descendant
+      CALL flxddraf(ztenh,    zqenh,
+     *     zgeoh,    paph,     zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     lddraf, pen_d, pde_d)
+c
+c calculer de nouveau le flux de masse entrant a travers la base
+c de la convection, sachant qu'il a ete modifie par le panache
+c descendant
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         ikb = kcbot(i)
+         llo1 = PMFD(i,ikb).LT.0.
+         zeps = 0.
+         IF ( llo1 ) zeps = CMFDEPS
+         zqumqe = pqu(i,ikb)+plu(i,ikb)-
+     .            zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb)
+         zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10)
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)
+     .       .AND.zmfub(i).LT.zmfmax) THEN
+            zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub1(i) = zmfub(i)
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)-
+     .            (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh
+         ENDIF
+         IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND.
+     .              ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) )
+     .      zmfub1(i) = zmfub(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         zfac = zmfub1(i)/MAX(zmfub(i),1.E-10)
+         pmfd(i,k) = pmfd(i,k)*zfac
+         zmfds(i,k) = zmfds(i,k)*zfac
+         zmfdq(i,k) = zmfdq(i,k)*zfac
+         zdmfdp(i,k) = zdmfdp(i,k)*zfac
+         pen_d(i,k) = pen_d(i,k)*zfac
+         pde_d(i,k) = pde_d(i,k)*zfac
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (lddraf(i)) zmfub(i)=zmfub1(i)
+      ENDDO
+c
+      ENDIF   ! fin de test sur lmfdd
+c
+c-----------------------------------------------------------------------
+c calculer de nouveau le panache ascendant
+c-----------------------------------------------------------------------
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+c
+c-----------------------------------------------------------------------
+c determiner les flux convectifs en forme finale, ainsi que
+c la quantite des precipitations
+c-----------------------------------------------------------------------
+      CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, 
+     .     ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum,
+     .     pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude,
+     .     zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2,
+     .     pmflxr, pmflxs)
+c
+c----------------------------------------------------------------------
+c calculer les tendances pour T et Q
+c----------------------------------------------------------------------
+      CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten,
+     e     zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel,
+     s     dt_con,dq_con)
+c
+ 1000 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh,
+     .           pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq,
+     .           pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude,
+     .           klab,pen_u, pde_u, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+C AND INITIALIZES VALUES FOR UPDRAFTS
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pten(klon,klev)   ! temperature (environnement)
+      REAL pqen(klon,klev)   ! humidite (environnement)
+      REAL pqsen(klon,klev)  ! humidite saturante (environnement)
+      REAL pgeo(klon,klev)   ! geopotentiel (g * metre)
+      REAL pgeoh(klon,klev)  ! geopotentiel aux demi-niveaux
+      REAL paph(klon,klev+1) ! pression aux demi-niveaux
+      REAL ptenh(klon,klev)  ! temperature aux demi-niveaux
+      REAL pqenh(klon,klev)  ! humidite aux demi-niveaux
+      REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux
+C
+      REAL ptu(klon,klev)    ! temperature du panache ascendant (p-a)
+      REAL pqu(klon,klev)    ! humidite du p-a
+      REAL plu(klon,klev)    ! eau liquide du p-a
+      REAL pmfu(klon,klev)   ! flux de masse du p-a
+      REAL pmfus(klon,klev)  ! flux de l'energie seche dans le p-a
+      REAL pmfuq(klon,klev)  ! flux de l'humidite dans le p-a
+      REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a
+      REAL plude(klon,klev)  ! quantite de l'eau liquide jetee du
+c                              p-a a l'environnement
+      REAL pdpmel(klon,klev) ! quantite de neige fondue
+c
+      REAL ptd(klon,klev)    ! temperature du panache descendant (p-d)
+      REAL pqd(klon,klev)    ! humidite du p-d
+      REAL pmfd(klon,klev)   ! flux de masse du p-d
+      REAL pmfds(klon,klev)  ! flux de l'energie seche dans le p-d
+      REAL pmfdq(klon,klev)  ! flux de l'humidite dans le p-d
+      REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d
+c
+      REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a
+      REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a
+      REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d
+      REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d
+C
+      INTEGER  klab(klon,klev)
+      LOGICAL  llflag(klon)
+      INTEGER k, i, icall
+      REAL zzs
+C----------------------------------------------------------------------
+C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+C----------------------------------------------------------------------
+      DO 130 k = 2, klev
+c
+      DO i = 1, klon
+         pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5
+         ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1),
+     .             RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD
+         pqsenh(i,k)=pqsen(i,k-1)
+         llflag(i)=.TRUE.
+      ENDDO
+c
+      icall=0
+      CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall)
+c
+      DO i = 1, klon
+         pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1))
+     .               +(pqsenh(i,k)-pqsen(i,k-1))
+         pqenh(i,k)=MAX(pqenh(i,k),0.)
+      ENDDO
+c
+  130 CONTINUE
+C
+      DO 140 i = 1, klon
+         ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)-
+     1                   pgeoh(i,klev))/RCPD
+         pqenh(i,klev)=pqen(i,klev)
+         ptenh(i,1)=pten(i,1)
+         pqenh(i,1)=pqen(i,1)
+         pgeoh(i,1)=pgeo(i,1)
+  140 CONTINUE
+c
+      DO 160 k = klev-1, 2, -1
+      DO 150 i = 1, klon
+         zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k),
+     .             RCPD*ptenh(i,k+1)+pgeoh(i,k+1))
+         ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD
+  150 CONTINUE
+  160 CONTINUE
+C
+C-----------------------------------------------------------------------
+C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+C-----------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         ptu(i,k) = ptenh(i,k)
+         pqu(i,k) = pqenh(i,k)
+         plu(i,k) = 0.
+         pmfu(i,k) = 0.
+         pmfus(i,k) = 0.
+         pmfuq(i,k) = 0.
+         pdmfup(i,k) = 0.
+         pdpmel(i,k) = 0.
+         plude(i,k) = 0.
+c
+         klab(i,k) = 0
+c
+         ptd(i,k) = ptenh(i,k)
+         pqd(i,k) = pqenh(i,k)
+         pmfd(i,k) = 0.0
+         pmfds(i,k) = 0.0
+         pmfdq(i,k) = 0.0
+         pdmfdp(i,k) = 0.0
+c
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph,
+     *     ptu, pqu, plu, ldcum, kcbot, klab)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+C
+C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+C   klab=1 FOR SUBCLOUD LEVELS
+C   klab=2 FOR CONDENSATION LEVEL
+C
+C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C       ----------------------------------------------------------------
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      INTEGER  klab(klon,klev), kcbot(klon)
+C
+      LOGICAL llflag(klon), ldcum(klon)
+      INTEGER i, k, icall, is
+      REAL zbuo, zqold(klon)
+C----------------------------------------------------------------------
+C INITIALIZE VALUES AT LIFTING LEVEL
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,klev)=1
+         kcbot(i)=klev-1
+         ldcum(i)=.FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C DO ASCENT IN SUBCLOUD LAYER,
+C CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+C ADJUST T,Q AND L ACCORDINGLY
+C CHECK FOR BUOYANCY AND SET FLAGS
+C----------------------------------------------------------------------
+      DO 290 k = klev-1, 2, -1
+c
+      is = 0
+      DO i = 1, klon
+         IF (klab(i,k+1).EQ.1) is = is + 1
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+      DO i = 1, klon
+      IF(llflag(i)) THEN
+         pqu(i,k) = pqu(i,k+1)
+         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k) = 1
+         zqold(i) = pqu(i,k)
+      ENDIF
+      ENDDO
+c
+      icall=1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+c
+      DO i = 1, klon
+      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) kcbot(i) = k
+         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+  290 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen,
+     .     pgeo, pgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, klab, ptu, pqu, plu,
+     .     pmfu, pmfub, pentr, pmfus, pmfuq,
+     .     pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum,
+     .     pen_u, pde_u)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+C FOR CUMULUS PARAMETERIZATION
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL pdtime
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pgeo(klon,klev), pgeoh(klon,klev)
+      REAL pap(klon,klev), paph(klon,klev+1)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev) ! vitesse verticale en Pa/s
+C
+      REAL pmfub(klon), pentr(klon)
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pdmfup(klon,klev)
+      INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon)
+      INTEGER kctop0(klon)
+      LOGICAL ldland(klon), ldcum(klon)
+C
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL zqold(klon)
+      REAL zdland(klon)
+      LOGICAL llflag(klon)
+      INTEGER k, i, is, icall, kcum
+      REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+      REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+c
+      REAL zpbot(klon), zptop(klon), zrho(klon)
+      REAL zdprho, zentr, zpmid, zmftest, zmfmax
+      LOGICAL llo1, llo2
+c
+      REAL zwmax(klon), zzzmb
+      INTEGER klwmin(klon) ! level of maximum vertical velocity
+C----------------------------------------------------------------------
+      ztglace = RTT - 13.
+c
+c Chercher le niveau ou la vitesse verticale est maximale:
+      DO i = 1, klon
+         klwmin(i) = klev
+         zwmax(i) = 0.0
+      ENDDO
+      DO k = klev, 3, -1
+      DO i = 1, klon
+      IF (pvervel(i,k).LT.zwmax(i)) THEN
+         zwmax(i) = pvervel(i,k)
+         klwmin(i) = k
+      ENDIF
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+C SET DEFAULT VALUES
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (.NOT.ldcum(i)) ktype(i)=0
+      ENDDO
+c
+      DO k=1,klev
+      DO i = 1, klon
+         plu(i,k)=0.
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         plude(i,k)=0.
+         pdmfup(i,k)=0.
+         IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0
+         IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (ldland(i)) THEN
+         zdland(i)=3.0E4
+         zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i))
+         IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi
+         zdland(i)=MAX(3.0E4,zdland(i))
+         zdland(i)=MIN(5.0E4,zdland(i))
+      ENDIF
+      ENDDO
+C
+C Initialiser les valeurs au niveau d'ascendance
+C
+      DO i = 1, klon
+         kctop(i) = klev-1
+         IF (.NOT.ldcum(i)) THEN
+            kcbot(i) = klev-1
+            pmfub(i) = 0.
+            pqu(i,klev) = 0.
+         ENDIF
+         pmfu(i,klev) = pmfub(i)
+         pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev))
+         pmfuq(i,klev) = pmfub(i)*pqu(i,klev)
+      ENDDO
+c
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C  DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+C  BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+C  BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+C  THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+C----------------------------------------------------------------------
+      DO 480 k = klev-1,3,-1
+c
+      IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN
+         DO i = 1, klon
+         IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND.
+     .       pqen(i,k).GT.0.9*pqsen(i,k)) THEN
+            ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD
+            pqu(i,k+1) = pqen(i,k)
+            plu(i,k+1) = 0.0
+            zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG)
+            zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime)
+            pmfub(i) = MIN(zzzmb,zmfmax)
+            pmfu(i,k+1) = pmfub(i)
+            pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1))
+            pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1)
+            pmful(i,k+1) = 0.0
+            pdmfup(i,k+1) = 0.0
+            kcbot(i) = k
+            klab(i,k+1) = 1
+            ktype(i) = 3
+            pentr(i) = ENTRMID
+         ENDIF
+         ENDDO
+      ENDIF
+c
+      is = 0
+      DO i = 1, klon
+         is = is + klab(i,k+1)
+         IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE.
+      ENDDO
+      IF (is .EQ. 0) GOTO 480
+c
+c calculer le taux d'entrainement et de detrainement
+c
+      DO i = 1, klon
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1))
+         zpbot(i)=paph(i,kcbot(i))
+         zptop(i)=paph(i,kctop0(i))
+      ENDDO
+c
+      DO 125 i = 1, klon
+      IF(ldcum(i)) THEN
+         zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i))
+         zentr=pentr(i)*pmfu(i,k+1)*zdprho
+         llo1=k.LT.kcbot(i)
+         IF(llo1) pde_u(i,k)=zentr
+         zpmid=0.5*(zpbot(i)+zptop(i))
+         llo2=llo1.AND.ktype(i).EQ.2.AND.
+     .        (zpbot(i)-paph(i,k).LT.0.2E5.OR.
+     .         paph(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND.
+     .        (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2)
+         IF(llo1) THEN
+            zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4)))
+            pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+            pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+         ENDIF
+         IF(llo2.AND.pqenh(i,k+1).GT.1.E-5)
+     .   pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)*
+     .              zrho(i)*zdprho
+      ENDIF
+  125 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+C----------------------------------------------------------------------
+c
+      DO 420 i = 1, klon
+      IF (llflag(i)) THEN
+         IF (k.LT.kcbot(i)) THEN
+            zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+            zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime))
+            pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0)
+         ENDIF
+         pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1))
+c calculer le flux de masse du niveau k a partir de celui du k+1
+         pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+c calculer les valeurs Su, Qu et l du niveau k dans le panache montant
+         zqeen=pqenh(i,k+1)*pen_u(i,k)
+         zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k)
+         zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k)
+         zqude=pqu(i,k+1)*pde_u(i,k)
+         plude(i,k)=plu(i,k+1)*pde_u(i,k)
+         zmfusk=pmfus(i,k+1)+zseen-zscde
+         zmfuqk=pmfuq(i,k+1)+zqeen-zqude
+         zmfulk=pmful(i,k+1)    -plude(i,k)
+         plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))-
+     1               pgeoh(i,k))/RCPD
+         ptu(i,k)=MAX(100.,ptu(i,k))
+         ptu(i,k)=MIN(400.,ptu(i,k))
+         zqold(i)=pqu(i,k)
+      ELSE
+         zqold(i)=0.0
+      ENDIF
+  420 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+C----------------------------------------------------------------------
+c
+      icall = 1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+C
+      DO 440 i = 1, klon
+      IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))
+         IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5
+         IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN
+            kctop(i) = k
+            ldcum(i) = .TRUE.
+            zdnoprc = 1.5E4
+            IF (ldland(i)) zdnoprc = zdland(i)
+            zprcon = CPRCON
+            IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0
+            zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+            pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+            plu(i,k)=zlnew
+         ELSE
+            klab(i,k)=0
+            pmfu(i,k)=0.
+         ENDIF
+      ENDIF
+  440 CONTINUE
+      DO 455 i = 1, klon
+      IF (llflag(i)) THEN
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+      ENDIF
+  455 CONTINUE
+C
+  480 CONTINUE
+C----------------------------------------------------------------------
+C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+C    (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+C           AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+C           FROM PREVIOUS CALCULATIONS ABOVE)
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE.
+         kcbot(i) = MAX(kcbot(i),kctop(i))
+      ENDDO
+c
+      ldcum(1)=ldcum(1)
+c
+      is = 0
+      DO i = 1, klon
+         if (ldcum(i)) is = is + 1
+      ENDDO
+      kcum = is
+      IF (is.EQ.0) GOTO 800
+c
+      DO 530 i = 1, klon
+      IF (ldcum(i)) THEN
+         k=kctop(i)-1
+         pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1)
+         plude(i,k)=pde_u(i,k)*plu(i,k+1)
+         pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k)
+         zlnew=plu(i,k)
+         pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+         plu(i,k)=zlnew
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         plude(i,k-1)=pmful(i,k)
+      ENDIF
+  530 CONTINUE
+C
+  800 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap
+     .  ,  paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop
+     .  ,  ktype, ldcum, pmfu, pmfd, pmfus, pmfds
+     .  ,  pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp
+     .  ,  pten, prfl, psfl, pdpmel, ktopm2
+     .  ,  pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL cevapcu(klon,klev)
+C     -----------------------------------------------------------------
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL paph(klon,klev+1), pgeoh(klon,klev)
+c
+      REAL pap(klon,klev)
+      REAL ztmsmlt, zdelta, zqsat
+C
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfdq(klon,klev)
+      REAL plude(klon,klev)
+      REAL pdmfup(klon,klev), pdpmel(klon,klev)
+cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+cjq 14/11/00 to fix the problem with the negative precipitation.      
+      REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) 
+      REAL prfl(klon), psfl(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+      INTEGER k, kp, i
+      REAL zcons1, zcons2, zcucov, ztmelp2
+      REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+      REAL zrmin, zrfln, zdrfl
+      REAL zpds, zpdr, zdenom
+      INTEGER ktopm2, itop, ikb
+c
+      LOGICAL lddraf(klon)
+      INTEGER kdtop(klon)
+c
+#include "FCTTRE.h"
+c
+      DO 101 k=1,klev
+        DO i=1,klon
+      CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293)
+     1 *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG
+        ENDDO
+ 101  CONTINUE
+c
+c SPECIFY CONSTANTS
+c
+      zcons1 = RCPD/(RLMLT*RG*pdtime)
+      zcons2 = 1./(RG*pdtime)
+      zcucov = 0.05
+      ztmelp2 = RTT + 2.
+c
+c DETERMINE FINAL CONVECTIVE FLUXES
+c
+      itop=klev
+      DO 110 i = 1, klon
+         itop=MIN(itop,kctop(i))
+         IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE.
+         IF(.NOT.ldcum(i)) ktype(i)=0
+  110 CONTINUE
+c
+      ktopm2=itop-2
+      DO 120 k=ktopm2,klev
+      DO 115 i = 1, klon
+      IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN
+         pmfus(i,k)=pmfus(i,k)-pmfu(i,k)*
+     .                (RCPD*ptenh(i,k)+pgeoh(i,k))
+         pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k)
+         zdp = 1.5E4
+         IF ( ldland(i) ) zdp = 3.E4
+c
+c        l'eau liquide detrainee est precipitee quand certaines
+c        conditions sont reunies (sinon, elle est consideree
+c        evaporee dans l'environnement)
+c
+         IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND.
+     .      pqen(i,k-1).GT.0.8*pqsen(i,k-1))
+     .      pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1)
+c
+         IF(lddraf(i).AND.k.GE.kdtop(i)) THEN
+            pmfds(i,k)=pmfds(i,k)-pmfd(i,k)*
+     .                   (RCPD*ptenh(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k)
+         ELSE
+            pmfd(i,k)=0.
+            pmfds(i,k)=0.
+            pmfdq(i,k)=0.
+            pdmfdp(i,k-1)=0.
+         END IF
+      ELSE
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         pdmfup(i,k-1)=0.
+         plude(i,k-1)=0.
+         pmfd(i,k)=0.
+         pmfds(i,k)=0.
+         pmfdq(i,k)=0.
+         pdmfdp(i,k-1)=0.
+      ENDIF
+  115 CONTINUE
+  120 CONTINUE
+c
+      DO 130 k=ktopm2,klev
+      DO 125 i = 1, klon
+      IF(ldcum(i).AND.k.GT.kcbot(i)) THEN
+         ikb=kcbot(i)
+         zzp=((paph(i,klev+1)-paph(i,k))/
+     .        (paph(i,klev+1)-paph(i,ikb)))
+         IF (ktype(i).EQ.3) zzp = zzp**2
+         pmfu(i,k)=pmfu(i,ikb)*zzp
+         pmfus(i,k)=pmfus(i,ikb)*zzp
+         pmfuq(i,k)=pmfuq(i,ikb)*zzp
+         pmful(i,k)=pmful(i,ikb)*zzp
+      ENDIF
+  125 CONTINUE
+  130 CONTINUE
+c
+c CALCULATE RAIN/SNOW FALL RATES
+c CALCULATE MELTING OF SNOW
+c CALCULATE EVAPORATION OF PRECIP
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,k) = 0.0
+         pmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i)) THEN
+         IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN
+            zfac=zcons1*(paph(i,k+1)-paph(i,k))
+            zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2))
+            pdpmel(i,k)=zsnmlt
+            ztmsmlt=pten(i,k)-zsnmlt/zfac
+            zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt))
+            zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k)
+            zqsat=MIN(0.5,zqsat)
+            zqsat=zqsat/(1.-RETV  *zqsat)
+            pqsen(i,k) = zqsat
+         ENDIF
+         IF (pten(i,k).GT.RTT) THEN
+         pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k)
+         ELSE
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)
+           pmflxr(i,k+1)=pmflxr(i,k)
+         ENDIF
+c        si la precipitation est negative, on ajuste le plux du
+c        panache descendant pour eliminer la negativite
+         IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN
+            pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k)
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cjq The new variable is initialized here.
+cjq It contains the humidity which is fed to the downdraft
+cjq by evaporation of precipitation in the column below the base
+cjq of convection.
+cjq 
+cjq In the former version, this term has been subtracted from precip
+cjq as well as the evaporation.
+cjq      
+      DO k = 1, klev
+      DO i = 1, klon 
+         maxpdmfdp(i,k)=0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+       DO kp = k, klev
+        DO i = 1, klon
+         maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp)
+        ENDDO
+       ENDDO
+      ENDDO
+cjq End of initialization
+c      
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN
+         zrfl = pmflxr(i,k) + pmflxs(i,k)
+         IF (zrfl.GT.1.0E-20) THEN
+            zrnew=(MAX(0.,SQRT(zrfl/zcucov)-
+     .            CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))*
+     .            MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov
+            zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k))
+     .            *zcons2*(paph(i,k+1)-paph(i,k))
+            zrnew=MAX(zrnew,zrmin)
+            zrfln=MAX(zrnew,0.)
+            zdrfl=MIN(0.,zrfln-zrfl)
+cjq At least the amount of precipiation needed to feed the downdraft
+cjq with humidity below the base of convection has to be left and can't
+cjq be evaporated (surely the evaporation can't be positive):            
+            zdrfl=MAX(zdrfl,
+     .            MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0))
+cjq End of insertion
+c            
+            zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k))
+            IF (pten(i,k).GT.RTT) THEN
+               zpdr = pdmfdp(i,k)
+               zpds = 0.0
+            ELSE
+               zpdr = 0.0
+               zpds = pdmfdp(i,k)
+            ENDIF
+            pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k)
+     .                    + zdrfl*pmflxr(i,k)*zdenom
+            pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k)
+     .                    + zdrfl*pmflxs(i,k)*zdenom
+            pdmfup(i,k) = pdmfup(i,k) + zdrfl
+         ELSE
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdmfdp(i,k) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) 
+     .    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 210 i = 1, klon
+         prfl(i) = pmflxr(i,klev+1)
+         psfl(i) = pmflxs(i,klev+1)
+  210 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten
+     .  ,  pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp
+     .  ,  pdpmel, dt_con, dq_con)
+      USE dimphy
+      IMPLICIT none
+c----------------------------------------------------------------------
+c calculer les tendances T et Q
+c----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     -----------------------------------------------------------------
+      LOGICAL  llo1
+C
+      REAL pten(klon,klev), paph(klon,klev+1)
+      REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfup(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL pdpmel(klon,klev)
+      LOGICAL ldcum(klon)
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+c
+      INTEGER ktopm2
+      REAL pdtime
+c
+      INTEGER i, k
+      REAL zalv, zdtdt, zdqdt
+c
+      DO 210 k=ktopm2,klev-1
+      DO 220 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .        *(pmfus(i,k+1)-pmfus(i,k)
+     .         +pmfds(i,k+1)-pmfds(i,k)
+     .          -RLMLT*pdpmel(i,k)
+     .          -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+     .         )
+         dt_con(i,k)=zdtdt
+         zdqdt=RG/(paph(i,k+1)-paph(i,k))
+     .        *(pmfuq(i,k+1)-pmfuq(i,k)
+     .         +pmfdq(i,k+1)-pmfdq(i,k)
+     .          +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  220 CONTINUE
+  210 CONTINUE
+C
+      k = klev
+      DO 230 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .         *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k)
+     .           -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+         dt_con(i,k)=zdtdt
+         zdqdt=-RG/(paph(i,k+1)-paph(i,k))
+     .            *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)
+     .             +pdmfup(i,k)+pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  230 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu,
+     .     ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd,
+     .     pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+C
+C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+C FOR MASSFLUX CUMULUS PARAMETERIZATION
+C
+C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+C AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+C
+C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+C MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev)
+      REAL pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+      REAL ptu(klon,klev), pqu(klon,klev)
+      REAL pmfub(klon)
+      REAL prfl(klon)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      INTEGER  kcbot(klon), kctop(klon), kdtop(klon)
+      LOGICAL  ldcum(klon), lddraf(klon)
+C
+      REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon)
+      REAL zttest, zqtest, zbuo, zmftop
+      LOGICAL  llo2(klon)
+      INTEGER i, k, is, icall
+C----------------------------------------------------------------------
+      DO i= 1, klon
+         lddraf(i)=.FALSE.
+         kdtop(i)=klev+1
+      ENDDO
+C
+C----------------------------------------------------------------------
+C DETERMINE LEVEL OF FREE SINKING BY
+C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+C
+C FOR EVERY POINT AND PROCEED AS FOLLOWS:
+C     (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+C     (2) DO MIXING WITH CUMULUS CLOUD AIR
+C     (3) CHECK FOR NEGATIVE BUOYANCY
+C
+C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+C EVAPORATION OF RAIN AND CLOUD WATER)
+C----------------------------------------------------------------------
+C
+      DO 290 k = 3, klev-3
+C
+      is=0
+      DO 212 i= 1, klon
+         ztenwb(i,k)=ptenh(i,k)
+         zqenwb(i,k)=pqenh(i,k)
+         llo2(i) = ldcum(i).AND.prfl(i).GT.0.
+     .             .AND..NOT.lddraf(i)
+     .             .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i))
+         IF ( llo2(i) ) is = is + 1
+  212 CONTINUE
+      IF(is.EQ.0) GO TO 290
+C
+      icall=2
+      CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+C
+C----------------------------------------------------------------------
+C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+C AND CHECK FOR NEGATIVE BUOYANCY.
+C THEN SET VALUES FOR DOWNDRAFT AT LFS.
+C----------------------------------------------------------------------
+      DO 222 i= 1, klon
+      IF (llo2(i)) THEN
+         zttest=0.5*(ptu(i,k)+ztenwb(i,k))
+         zqtest=0.5*(pqu(i,k)+zqenwb(i,k))
+         zbuo=zttest*(1.+RETV*zqtest)-
+     .        ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         zcond(i)=pqenh(i,k)-zqenwb(i,k)
+         zmftop=-CMFDEPS*pmfub(i)
+         IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN
+            kdtop(i)=k
+            lddraf(i)=.TRUE.
+            ptd(i,k)=zttest
+            pqd(i,k)=zqtest
+            pmfd(i,k)=zmftop
+            pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfd(i,k)*pqd(i,k)
+            pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i)
+            prfl(i)=prfl(i)+pdmfdp(i,k-1)
+         ENDIF
+      ENDIF
+  222 CONTINUE
+c
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl,
+     .           ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp,
+     .           lddraf, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+C
+C          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+C          (I.E. T,Q,U AND V AND FLUXES)
+C
+C          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+C          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+C          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+C
+C          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+C          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+C          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+C
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon)
+      LOGICAL lddraf(klon)
+C
+      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
+      LOGICAL llo2(klon), llo1
+      INTEGER i, k, is, icall, itopde
+      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+      REAL zbuo
+C----------------------------------------------------------------------
+C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+C       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+C           LINEAR DECREASE OF MASSFLUX IN PBL
+C       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+C           AND MOISTENING IS CALCULATED IN *flxadjtq*
+C       (C) CHECKING FOR NEGATIVE BUOYANCY AND
+C           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+C
+      DO 180 k = 3, klev
+c
+      is = 0
+      DO i = 1, klon
+         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
+         IF (llo2(i)) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 180
+c
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/
+     .           (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
+         pen_d(i,k) = zentr
+         pde_d(i,k) = zentr
+      ENDIF
+      ENDDO
+c
+      itopde = klev-2
+      IF (k.GT.itopde) THEN
+         DO i = 1, klon
+         IF (llo2(i)) THEN
+            pen_d(i,k)=0.
+            pde_d(i,k)=pmfd(i,itopde)*
+     .      (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
+         ENDIF
+         ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
+         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
+         zqeen = pqenh(i,k-1)*pen_d(i,k)
+         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
+         zqdde = pqd(i,k-1)*pde_d(i,k)
+         zmfdsk = pmfds(i,k-1)+zseen-zsdde
+         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
+         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
+         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))-
+     .               pgeoh(i,k))/RCPD
+         ptd(i,k) = MIN(400.,ptd(i,k))
+         ptd(i,k) = MAX(100.,ptd(i,k))
+         zcond(i) = pqd(i,k)
+      ENDIF
+      ENDDO
+C
+      icall = 2
+      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zcond(i) = zcond(i)-pqd(i,k)
+         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))-
+     .          ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
+         IF (.not.llo1) pmfd(i,k) = 0.0
+         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
+         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
+         zdmfdp = -pmfd(i,k)*zcond(i)
+         pdmfdp(i,k-1) = zdmfdp
+         prfl(i) = prfl(i)+zdmfdp
+      ENDIF
+      ENDDO
+c
+  180 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Objet: ajustement entre T et Q
+c======================================================================
+C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+C        kcall=0    ENV. T AND QS IN*CUINI*
+C        kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL ldflag(klon)
+      INTEGER kcall
+c
+      REAL zcond(klon), zcond1
+      REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      z5alvcp = r5les*RLVTT/RCPD
+      z5alscp = r5ies*RLSTT/RCPD
+      zalvdcp = rlvtt/RCPD
+      zalsdcp = rlstt/RCPD
+C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
+      DO 210 i =1, klon
+      IF (ldflag(i)) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond(i) = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor))
+         IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.)
+         IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.)
+         pt(i) = pt(i) + zldcp*zcond(i)
+         pq(i) = pq(i) - zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i =1, klon
+         IF (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(ldflag(i).AND.zcond(i).NE.0.) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond1 = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor))
+         pt(i) = pt(i) + zldcp*zcond1
+         pq(i) = pq(i) - zcond1
+      ENDIF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxsetup
+      IMPLICIT none
+C
+C     THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+C
+#include "YOECUMF.h"
+C
+      ENTRPEN=1.0E-4  ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+      ENTRSCV=3.0E-4  ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+      ENTRMID=1.0E-4  ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+      ENTRDD =2.0E-4  ! ENTRAINMENT RATE FOR DOWNDRAFTS
+      CMFCTOP=0.33  ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+      CMFCMAX=1.0  ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+      CMFCMIN=1.E-10  ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+      CMFDEPS=0.3  ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+      CPRCON =2.0E-4  ! CONVERSION FROM CLOUD WATER TO RAIN
+      RHCDD=1.  ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+c                 (FORMULATION IMPLIES SATURATION)
+      LMFPEN = .TRUE.
+      LMFSCV = .TRUE.
+      LMFMID = .TRUE.
+      LMFDD = .TRUE.
+      LMFDUDV = .TRUE.
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/conlmd.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/conlmd.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/conlmd.F	(revision 984)
@@ -0,0 +1,2321 @@
+!
+! $Header$
+!
+      SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q,
+     s                   d_t, d_q, rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection utilis'e dans le modele du LMD
+c        Ajustement humide (Manabe) + Ajustement convectif (Kuo)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql(klon,klev), d_ql_bis(klon,klev)
+      REAL rneb(klon,klev), rneb_bis(klon,klev)
+c
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+ccc      CALL fiajh ! ancienne version de Convection Manabe
+      CALL conman ! nouvelle version de Convection Manabe
+     e     (dtime, paprs, pplay, t, q,
+     s      d_t, d_q, d_ql, rneb,
+     s      rain, snow, ibas, itop)
+c
+      IF (usekuo) THEN
+ccc      CALL fiajc ! ancienne version de Convection Kuo
+      CALL conkuo ! nouvelle version de Convection Kuo
+     e     (dtime, paprs, pplay, t, q, conv_q,
+     s      d_t_bis, d_q_bis, d_ql_bis, rneb_bis, 
+     s      rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+         d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         ibas(i) = MIN(ibas(i),ibas_bis(i))
+         itop(i) = MAX(itop(i),itop_bis(i))
+      ENDDO
+      ENDIF
+c
+c L'eau liquide convective est dispersee dans l'air:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE conman (dtime, paprs, pplay, t, q,
+     s                   d_t, d_q, d_ql, rneb,
+     s                   rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
+c Objet: ajustement humide convectif avec la possibilite de faire
+c        l'ajustement sur une fraction de la maille.
+c Methode: On impose une distribution uniforme pour la vapeur d'eau
+c au sein d'une maille. On applique la procedure d'ajustement
+c successivement a la totalite, 75%, 50%, 25% et 5% de la maille
+c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
+c les activites convectives et corrige le biais "trop froid et sec"
+c du modele.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL afaire(klon)   ! .TRUE. implique l'ajustement
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
+c
+      INTEGER nb ! nombre de sous-fractions a considere
+      PARAMETER (nb=1)
+ccc      PARAMETER (nb=3)
+c
+      REAL ratqs ! largeur de la distribution pour vapeur d'eau
+      PARAMETER (ratqs=0.05)
+c
+      REAL w_q(klon,klev)
+      REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev)
+      REAL w_rneb(klon,klev)
+      REAL w_rain(klon), w_snow(klon)
+      INTEGER w_ibas(klon), w_itop(klon)
+      REAL zq1, zq2
+      INTEGER i, k, n
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL zdp1, zdp2
+      REAL zqs1, zqs2, zdqs1, zdqs2
+      REAL zgamdz
+      REAL zflo ! flotabilite
+      REAL zsat ! sur-saturation
+      REAL zdelta, zcor, zcvm5
+      LOGICAL imprim
+c
+      INTEGER ncpt
+      SAVE ncpt
+c$OMP THREADPRIVATE(ncpt)
+      REAL frac(nb) ! valeur de la maille fractionnelle
+      SAVE frac
+c$OMP THREADPRIVATE(frac)
+      INTEGER opt_cld(nb) ! option pour le modele nuageux
+      SAVE opt_cld
+c$OMP THREADPRIVATE(opt_cld)
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA frac / 1.0 /
+      DATA opt_cld / 4 /
+ccc      DATA frac    / 1.0, 0.50, 0.25/
+ccc      DATA opt_cld / 4,   4,    4/
+c
+      DATA appel1er /.TRUE./
+      DATA ncpt /0/
+c
+      IF (appel1er) THEN
+         PRINT*, 'conman, nb:', nb
+         PRINT*, 'conman, frac:', frac
+         PRINT*, 'conman, opt_cld:', opt_cld
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c S'il n'y a pas d'instabilite conditionnelle,
+c pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         afaire(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev-1
+      DO i = 1, klon
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+            zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+            zqs1=MIN(0.5,zqs1)
+            zcor=1./(1.-RETV*zqs1)
+            zqs1=zqs1*zcor
+            zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor)
+c
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1))
+            zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1)
+            zqs2=MIN(0.5,zqs2)
+            zcor=1./(1.-RETV*zqs2)
+            zqs2=zqs2*zcor
+            zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor)
+         ELSE
+           IF (t(i,k) .LT. t_coup) THEN
+              zqs1= qsats(t(i,k)) / pplay(i,k)
+              zdqs1= dqsats(t(i,k),zqs1)
+c
+              zqs2= qsats(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsats(t(i,k+1),zqs2)
+           ELSE
+              zqs1= qsatl(t(i,k)) / pplay(i,k)
+              zdqs1= dqsatl(t(i,k),zqs1)
+c
+              zqs2= qsatl(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsatl(t(i,k+1),zqs2)
+           ENDIF
+         ENDIF
+         zdp1 = paprs(i,k) - paprs(i,k+1)
+         zdp2 = paprs(i,k+1) - paprs(i,k+2)
+         zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(t(i,k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)
+     .            +RLVTT*(zqs1*zdp1+zqs2*zdp2)/(zdp1+zdp2)
+     .           ) / (1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2) )
+         zflo = t(i,k) + zgamdz - t(i,k+1)
+         zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
+         IF (zflo.GT.0.0) afaire(i) = .TRUE.
+c erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
+      ENDDO
+      ENDDO
+c
+      imprim = MOD(ncpt,48).EQ.0
+      DO 99999 n = 1, nb
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zq1 = q(i,k) * (1.0-ratqs)
+         zq2 = q(i,k) * (1.0+ratqs)
+         w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      CALL conmanv (dtime, paprs, pplay, t, w_q,
+     e              afaire, opt_cld(n),
+     s              w_d_t, w_d_q, w_d_ql, w_rneb,
+     s              w_rain, w_snow, w_ibas, w_itop,accompli,imprim)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         d_t(i,k) = w_d_t(i,k) * frac(n)
+         d_q(i,k) = w_d_q(i,k) * frac(n)
+         d_ql(i,k) = w_d_ql(i,k) * frac(n)
+         IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n)
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         rain(i) = w_rain(i) * frac(n)
+         snow(i) = w_snow(i) * frac(n)
+         ibas(i) = MIN(ibas(i),w_ibas(i))
+         itop(i) = MAX(itop(i),w_itop(i))
+      ENDIF
+      ENDDO
+      DO i = 1, klon
+         IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
+      ENDDO
+c
+99999 CONTINUE
+c
+      ncpt = ncpt + 1
+c
+      RETURN
+      END
+      SUBROUTINE conmanv (dtime, paprs, pplay, t, q,
+     e                    afaire, opt_cld,
+     s                    d_t, d_q, d_ql, rneb,
+     s                    rain, snow, ibas, itop,accompli,imprim)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement humide (convection proposee par Manabe).
+c        Pour une colonne verticale, il peut avoir plusieurs blocs
+c        necessitant l'ajustement. ibas est le bas du plus bas bloc
+c        et itop est le haut du plus haut bloc
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
+      LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
+c
+c Quelques options:
+c
+      LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
+      PARAMETER (new_top=.FALSE.)
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+      LOGICAL old_tau ! implique precip nulle, si vrai.
+      PARAMETER (old_tau=.FALSE.)
+      REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+      REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+      PARAMETER (dpmin=0.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
+      LOGICAL exigent ! implique un calcul supplementaire pour Qs
+      PARAMETER (exigent=.FALSE.)
+c
+      INTEGER kbase
+      PARAMETER (kbase=0)
+c
+c Variables locales:
+c
+      INTEGER nexpo
+      INTEGER i, k, k1min, k1max, k2min, k2max, is
+      REAL zgamdz(klon,klev-1)
+      REAL zt(klon,klev), zq(klon,klev)
+      REAL zqs(klon,klev), zdqs(klon,klev)
+      REAL zqmqsdp(klon,klev)
+      REAL ztnew(klon,klev), zqnew(klon,klev)
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zsat(klon) ! sur-saturation
+      REAL zflo(klon) ! flotabilite
+      REAL za(klon), zb(klon), zc(klon)
+      INTEGER k1(klon), k2(klon)
+      REAL zdelta, zcor, zcvm5
+      REAL delp(klon,klev)
+      LOGICAL possible(klon), todo(klon), etendre(klon)
+      LOGICAL aller(klon), todobis(klon)
+      REAL zalfa
+      INTEGER nbtodo, nbdone
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k) - paprs(i,k+1)
+      ENDDO
+      ENDDO
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+         accompli(i) = .FALSE.
+      ENDDO
+c
+c Preparations
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zt(i,k) = t(i,k)
+         zq(i,k) = q(i,k) 
+c
+c        Calculer Qs et L/Cp*dQs/dT
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+c
+c        Calculer (q-qs)*dp
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c-----zgama is the moist convective lapse rate (-dT/dz).
+c-----zgamdz(*,k) est la difference minimale autorisee des temperatures
+c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
+c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c On cherche la presence simultanee d'instabilite conditionnelle
+c et de sur-saturation. Sinon, pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (possible(i)) THEN
+         k1(i) = kbase
+         k2(i) = k1(i) + 1
+      ENDIF
+      ENDDO
+c
+  810 CONTINUE ! chercher le bas de la colonne a ajuster
+c
+      k2min = klev
+      DO i = 1, klon
+         todo(i) = .FALSE.
+         aller(i) = .TRUE.
+         IF (possible(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.EQ.klev) GOTO 860
+      DO k = k2min, klev-1
+      DO i = 1, klon
+      IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            k1(i) = k
+            k2(i) = k+1
+            todo(i) = .TRUE.
+            aller(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (possible(i).AND.aller(i)) THEN
+         todo(i) = .FALSE.
+         k1(i) = klev
+         k2(i) = klev
+      ENDIF
+      ENDDO
+c
+CCC      DO i = 1, klon
+CCC      IF (possible(i)) THEN
+CCC  811    k2(i) = k2(i) + 1
+CCC         IF (k2(i) .GT. klev) THEN
+CCC            todo(i) = .FALSE.
+CCC            GOTO 812
+CCC         ENDIF
+CCC         k = k2(i)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
+CCC         k1(i) = k2(i) - 1
+CCC         todo(i) = .TRUE.
+CCC      ENDIF
+CCC  812 CONTINUE
+CCC      ENDDO
+c
+  820 CONTINUE ! chercher le haut de la colonne
+c
+      k2min = klev
+      DO i = 1, klon
+         aller(i) = .TRUE.
+         IF (todo(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.LT.klev) THEN
+      DO k = k2min, klev
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN
+            zsat(i) = zsat(i) + zqmqsdp(i,k)
+            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+            IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+               aller(i) = .FALSE.
+            ELSE
+               k2(i) = k
+            ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c error      is = 0
+c error      DO i = 1, klon
+c error      IF(todo(i).AND.aller(i)) THEN
+c error         is = is + 1
+c error         todo(i) = .FALSE.
+c error         k2(i) = klev
+c error      ENDIF
+c error      ENDDO
+c error      IF (is.GT.0) THEN
+c error         PRINT*, "Bizard. je pourrais continuer mais j arrete"
+c error         CALL abort
+c error      ENDIF
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (todo(i)) THEN
+CCC  821    CONTINUE
+CCC         IF (k2(i) .EQ. klev) GOTO 822
+CCC         k = k2(i) + 1
+CCC         zsat(i) = zsat(i) + zqmqsdp(i,k)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
+CCC         k2(i) = k
+CCC         GOTO 821
+CCC      ENDIF
+CCC  822 CONTINUE
+CCC      ENDDO
+c
+  830 CONTINUE ! faire l'ajustement en sachant k1 et k2
+c
+      is = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (k2(i).LE.k1(i)) is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         PRINT*, "Impossible: k1 trop grand ou k2 trop petit"
+         PRINT*, "is=", is
+         CALL abort
+      ENDIF
+c
+      k1min = klev
+      k1max = 1
+      k2max = 1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k1min = MIN(k1min,k1(i))
+         k1max = MAX(k1max,k1(i))
+         k2max = MAX(k2max,k2(i))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      k = k1(i)
+      za(i) = 0.
+      zb(i) = ( RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .      -RLVTT*(zqs(i,k)-zq(i,k)) )*delp(i,k)
+      zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         za(i) = za(i) + zgamdz(i,k-1)
+         zb(i) = zb(i)+(RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .           -RLVTT*(zqs(i,k)-zq(i,k)) ) * delp(i,k)
+         zc(i) = zc(i) + delp(i,k)*RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k = k1(i)
+         ztnew(i,k) = zb(i)/zc(i)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                          *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                        *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Quantite de condensation produite pendant l'ajustement:
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         rneb(i,k) = 1.0
+         zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Si condensation negative, effort completement perdu:
+c
+      DO i = 1, klon
+         IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE.
+      ENDDO
+c
+c L'ajustement a ete accompli, meme les calculs accessoires
+c ne sont pas encore faits:
+c
+      DO i = 1, klon
+         IF (todo(i)) accompli(i) = .TRUE.
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1))
+     .                 /paprs(i,1)-dpmin)
+     .                 *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+      ENDIF
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de 
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+            zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k)
+         ENDIF
+         ENDDO
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .      zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k)) 
+     .                          * delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND.
+     .       zvapo(i).GT.0.0)
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,zq(i,k)-zqnew(i,k))
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse 
+         ENDDO                       ! (avec ponderation)
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k) / RG
+     .                    * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre evaporee:
+c
+      zalfa = 0.05
+      IF (evap_prec .AND. (k1max.GE.2)) THEN
+      DO k = k1max-1, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa )
+         zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .         * delp(i,k)/pplay(i,k)*zt(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k)
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime
+         zq(i,k) = zq(i,k) - (zrfln-zrfl(i)) 
+     .                     * (RG/(delp(i,k)))*dtime
+         zt(i,k) = zt(i,k) + (zrfln-zrfl(i))
+     .                     * (RG/(delp(i,k)))*dtime
+     .                     * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k))
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (zt(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+c Mise a jour de la temperature et de l'humidite
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         zt(i,k) = ztnew(i,k)
+         zq(i,k) = zqnew(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Re-calculer certaines variables pour etendre et re-ajuster la colonne
+c
+      IF (exigent) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (exigent) THEN
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Verifier si l'on peut etendre le bas de la colonne
+c
+      DO i = 1, klon
+         etendre(i) = .FALSE.
+      ENDDO
+c
+      k1max = 1
+      DO i = 1, klon
+      IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN
+         k = k1(i)
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+csc voici l'ancienne ligne:
+csc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+csc sylvain: il faut RESPECTER les 2 criteres:
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            etendre(i) = .TRUE.
+            k1(i) = k1(i) - 1
+            k1max = MAX(k1max,k1(i))
+            aller(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+c
+      IF (k1max.GT.(kbase+1)) THEN
+      DO k = k1max, kbase+1, -1
+      DO i = 1, klon
+      IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN
+         zsat(i) = zsat(i) + zqmqsdp(i,k)
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN
+            aller(i) = .FALSE.
+         ELSE
+            k1(i) = k
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (etendre(i).AND.aller(i)) THEN
+            k1(i) = 1
+         ENDIF
+      ENDDO
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (etendre(i)) THEN
+CCC  840    k = k1(i)
+CCC         IF (k.GT.1) THEN
+CCC            zsat(i) = zsat(i) + zqmqsdp(i,k-1)
+CCC            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC            IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+CCC               k1(i) = k - 1
+CCC               GOTO 840
+CCC            ENDIF
+CCC         ENDIF
+CCC      ENDIF
+CCC      ENDDO
+c
+      DO i = 1, klon
+         todobis(i) = todo(i)
+         todo(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (etendre(i)) THEN
+         todo(i) = .TRUE.
+         is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         IF (new_top) THEN
+            GOTO 820 ! chercher de nouveau le sommet k2
+         ELSE
+            GOTO 830 ! supposer que le sommet est celui deja trouve
+         ENDIF
+      ENDIF
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (todobis(i) .AND. k2(i).LT.klev) THEN
+         is = is + 1
+         possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks 
+c     a ajuster a partir du sommet de la colonne precedente
+c
+  860 CONTINUE ! Calculer les tendances et diagnostiques
+ccc      print*, "Apres 860"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (accompli(i)) THEN
+         d_t(i,k) = zt(i,k) - t(i,k)
+         zq(i,k) = MAX(zq(i,k),seuil_vap)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 888 i = 1, klon
+      IF (accompli(i)) THEN
+         DO k = 1, klev
+         IF (rneb(i,k).GT.0.0) THEN
+            ibas(i) = k
+            GOTO 807
+         ENDIF
+         ENDDO
+  807    CONTINUE
+         DO k = klev, 1, -1
+         IF (rneb(i,k).GT.0.0) THEN
+            itop(i) = k
+            GOTO 808
+         ENDIF
+         ENDDO
+  808    CONTINUE
+      ENDIF
+  888 CONTINUE
+c
+      IF (imprim) THEN
+         nbtodo = 0
+         nbdone = 0
+         DO i = 1, klon
+            IF (afaire(i)) nbtodo = nbtodo + 1
+            IF (accompli(i)) nbdone = nbdone + 1
+         ENDDO
+         PRINT*, "nbTodo, nbDone=", nbtodo, nbdone
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s                  d_t, d_q, d_ql, rneb, 
+     s                  rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection de type Kuo (1965).
+c        Cette version du code peut calculer le niveau de depart
+c N.B. version vectorielle (le 6 oct. 1997)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime               ! intervalle du temps (s)
+      REAL paprs(klon,klev+1)  ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)    ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)        ! temperature (K)
+      REAL q(klon,klev)        ! humidite specifique
+      REAL conv_q(klon,klev)   ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)      ! incrementation temperature
+      REAL d_q(klon,klev)      ! incrementation humidite
+      REAL d_ql(klon,klev)     ! incrementation eau liquide
+      REAL rneb(klon,klev)     ! nebulosite
+      REAL rain(klon)          ! pluies (mm/s)
+      REAL snow(klon)          ! neige (mm/s)
+      INTEGER itop(klon)       ! niveau du sommet
+      INTEGER ibas(klon)       ! niveau du bas
+c
+      LOGICAL ldcum(klon)      ! convection existe
+      LOGICAL todo(klon)
+c
+c Quelsques options:
+c
+      LOGICAL calcfcl ! calculer le niveau de convection libre
+      PARAMETER (calcfcl=.TRUE.)
+      INTEGER ldepar ! niveau fixe de convection libre
+      PARAMETER (ldepar=4)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      LOGICAL new_deh ! nouvelle facon de calculer dH
+      PARAMETER (new_deh=.FALSE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      LOGICAL old_tau ! implique precipitation nulle
+      PARAMETER (old_tau=.FALSE.)
+      REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+      REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+      PARAMETER (dpmin=0.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
+c
+c Variables locales:
+c
+      INTEGER nexpo
+      LOGICAL nuage(klon)
+      INTEGER i, k, kbmin, kbmax, khmax
+      REAL ztotal(klon,klev), zdeh(klon,klev)
+      REAL zgz(klon,klev)
+      REAL zqs(klon,klev)
+      REAL zdqs(klon,klev)
+      REAL ztemp(klon,klev)
+      REAL zpres(klon,klev)
+      REAL zconv(klon) ! convergence d'humidite
+      REAL zvirt(klon) ! convergence virtuelle d'humidite
+      REAL zfrac(klon) ! fraction convective
+      INTEGER kb(klon), kh(klon)
+c
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zdelta, zcvm5, zcor
+      REAL zvar
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c Fonctions thermodynamiques
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         PRINT*, 'conkuo, calcfcl:', calcfcl
+         IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar
+         PRINT*, 'conkuo, opt_cld:', opt_cld
+         PRINT*, 'conkuo, evap_prec:', evap_prec
+         PRINT*, 'conkuo, new_deh:', new_deh
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (t(i,k).LT.t_coup) THEN
+              zqs(i,k) = qsats(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsats(t(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsatl(t(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer gz (energie potentielle)
+c
+      DO i = 1, klon
+         zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                   * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgz(i,k) = zgz(i,k-1)
+     .            + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                 * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+c Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztotal(i,k) = RCPD*t(i,k) + RLVTT*zqs(i,k) + zgz(i,k)
+      ENDDO
+      ENDDO
+c
+c Determiner le niveau de depart et calculer la difference de
+c l'energie statique humide saturee (ztotal) entre la couche
+c de depart et chaque couche au-dessus.
+c
+      IF (calcfcl) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            zpres(i,k) = pplay(i,k)
+            ztemp(i,k) = t(i,k)
+         ENDDO
+         ENDDO
+         CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            k = kb(i)
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDIF
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+         IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN
+            IF (new_deh) THEN
+               zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+            ELSE
+               zdeh(i,k) = zdeh(i,k-1)
+     .                   + RCPD * (t(i,k-1)-t(i,k))
+     .                   - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                        *(pplay(i,k-1)-pplay(i,k))
+     .                   + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+         ENDIF
+         ENDDO
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            k = ldepar
+            kb(i) = ldepar
+            ldcum(i) = .TRUE.
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDDO
+         DO k = ldepar+1, klev
+         DO i = 1, klon
+         IF (new_deh) THEN
+             zdeh(i,k)  = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+         ELSE
+             zdeh(i,k) = zdeh(i,k-1)
+     .                 + RCPD * (t(i,k-1)-t(i,k))
+     .                 - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                      *(pplay(i,k-1)-pplay(i,k))
+     .                 + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c-----Chercher le sommet du nuage
+c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
+c-----psolpa/RG pres) du bas jusqu'au sommet du nuage.
+c-----Calculer la convergence virtuelle pour que toute la maille 
+c-----deviennt nuageuse (du bas jusqu'au sommet du nuage)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (k.GE.kb(i) .AND. ldcum(i)) THEN
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i) = k
+            zconv(i)=zconv(i)+conv_q(i,k)*dtime
+     .                       *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0
+      ENDDO
+c
+      kbmin = klev
+      kbmax = 0
+      khmax = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         kbmin = MIN(kbmin,kb(i))
+         kbmax = MAX(kbmax,kb(i))
+         khmax = MAX(khmax,kh(i))
+      ENDIF
+      ENDDO
+c
+c-----Calculer la surface couverte par le nuage
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0))
+      ENDIF
+      ENDDO
+c
+c-----Calculs essentiels:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zcond(i) = 0.0
+      ENDIF
+      ENDDO
+      DO k = kbmin, khmax
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+         zvar = zdeh(i,k)/(1.+zdqs(i,k))
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG
+         rneb(i,k) = zfrac(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i) .AND. zcond(i).LT.0.0) THEN
+         PRINT*, 'WARNING: cond. negative (Kuo) ',
+     .            i,kb(i),kh(i), zcond(i)
+         zcond(i) = 0.0
+         DO k = kb(i), kh(i)
+            d_t(i,k) = 0.0
+            d_q(i,k) = 0.0
+         ENDDO
+         todo(i) = .FALSE. ! effort totalement perdu
+      ENDIF
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1))
+     .               /paprs(i,1)-dpmin)
+     .             *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+      ENDIF
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k))
+     .                    * (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND.
+     .                     zvapo(i).GT.0.0) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,-d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG
+     .                    * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre re-evaporee:
+c
+      IF (evap_prec .AND. kbmax.GE.2) THEN
+      DO k = kbmax, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) )
+         zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .       * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*t(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                 /RG/dtime
+         d_q(i,k) = - (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         d_t(i,k) = (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .          * RLVTT/RCPD
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (t(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: calculer le niveau de convection libre
+c        (FCL: Free Convection Level)
+c======================================================================
+c Arguments:
+c pt---input-R- temperature (K)
+c pq---input-R- vapeur d'eau (kg/kg)
+c pg---input-R- geopotentiel (g*z ou z est en metre)
+c pp---input-R- pression (Pa)
+c
+c LDCUM---output-L- Y-t-il la convection
+c kcbot---output-I- Niveau du bas de la convection
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev)
+      INTEGER  kcbot(klon)
+      LOGICAL  LDCUM(klon)
+C
+      REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev)
+      REAL zqold(klon), zbuo
+      INTEGER is, i, k
+c
+c klab=1: on est sous le nuage convectif
+c klab=2: le bas du nuage convectif
+c klab=0: autres couches
+      INTEGER klab(klon,klev)
+c
+c quand lflag=.true., on est sous le nuage, il faut donc appliquer
+c le processus d'elevation.
+      LOGICAL lflag(klon)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         ztu(i,k) = pt(i,k)
+         zqu(i,k) = pq(i,k)
+         zlu(i,k) = 0.0
+         klab(i,k) = 0
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,1)=1
+         kcbot(i)=2
+         LDCUM(i)=.FALSE.
+      ENDDO
+C
+      DO 290 k = 2, klev-1
+c
+      is=0
+      DO i = 1, klon
+         if (klab(i,k-1).EQ.1) is = is + 1
+         lflag(i) = .FALSE.
+         if (klab(i,k-1).EQ.1) lflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+c on eleve le parcel d'air selon l'adiabatique sec
+c
+      DO i = 1, klon
+      IF (lflag(i)) THEN
+         zqu(i,k) = zqu(i,k-1)
+         ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k)=1
+         zqold(i) = zqu(i,k)
+      ENDIF
+      ENDDO
+c
+c on calcule la condensation eventuelle
+c
+      CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
+c
+c s'il y a la condensation et la "buoyancy" force est positive
+c c'est bien le bas de la tour de convection
+c
+      DO i=1, klon
+      IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k)
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) THEN
+            kcbot(i) = k
+            LDCUM(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+C
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: ajustement entre T et Q
+c======================================================================
+c Arguments:
+c pp---input-R- pression (Pa)
+c pt---input/output-R- temperature (K)
+c pq---input/output-R- vapeur d'eau (kg/kg)
+c======================================================================
+C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+C
+C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+C        KCALL=0    ENV. T AND QS IN*CUINI*
+C        KCALL=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL  ldflag(klon)
+      INTEGER KCALL
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zcond(klon), zcond1
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+C
+      DO 210 i=1, klon
+      IF (LDFLAG(i)) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond(i)=(pq(i)-zqsat) / (1. + zdqsat)
+         IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.)
+         IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.)
+         pt(i)=pt(i)+zldcp*zcond(i)
+         pq(i)=pq(i)-zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i=1, klon
+         if (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF(is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond1=(pq(i)-zqsat) / (1.+zdqsat)
+         pt(i)=pt(i)+zldcp*zcond1
+         pq(i)=pq(i)-zcond1
+      END IF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE fiajh(dtime, paprs, pplay, t, q,
+     .                 d_t, d_q, d_ql, rneb,
+     .                 rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT NONE
+c
+c Ajustement humide (Schema de convection de Manabe)
+C.
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime        ! intervalle du temps (s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL d_q(klon,klev) ! incrementation pour vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+c
+      REAL rain(klon)    ! variable non utilisee
+      REAL snow(klon)    ! variable non utilisee
+      INTEGER ibas(klon) ! variable non utilisee
+      INTEGER itop(klon) ! variable non utilisee
+
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+c
+c Variables locales:
+c 
+      INTEGER i, k
+      INTEGER k1, k1p, k2, k2p
+      LOGICAL itest(klon)
+      REAL delta_q(klon, klev)
+      REAL cp_new_t(klev)
+      REAL cp_delta_t(klev)
+      REAL new_qb(klev)
+      REAL v_cptj(klev), v_cptjk1, v_ssig
+      REAL v_cptt(klon,klev), v_p, v_t
+      REAL v_qs(klon,klev), v_qsd(klon,klev)
+      REAL zq1(klon), zq2(klon)
+      REAL gamcpdz(klon,2:klev)
+      REAL zdp, zdpm
+c
+      REAL zsat ! sur-saturation
+      REAL zflo ! flotabilite
+c
+      REAL local_q(klon,klev),local_t(klon,klev)
+c
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         local_q(i,k) = q(i,k)
+         local_t(i,k) = t(i,k)
+         rneb(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer v_qs et v_qsd:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer Gamma * Cp * dz: (gamm est le gradient critique)
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zdpm = paprs(i,k-1)-paprs(i,k)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * 
+     .                      (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) * 
+     .                      (v_qs(i,k-1)*zdpm + v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+
+     .                        v_qsd(i,k)*zdp)/(zdpm+zdp) )
+      ENDDO
+      ENDDO
+C
+C------------------------------------ modification des profils instables
+      DO 9999 i = 1, klon
+      itest(i) = .FALSE.
+C
+      k1 = 0
+      k2 = 1
+C
+  810 CONTINUE ! chercher k1, le bas de la colonne
+      k2 = k2 + 1
+      IF (k2 .GT. klev) GOTO 9999
+      zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2)
+      zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2))
+     .    +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
+      IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810
+      k1 = k2 - 1
+      itest(i) = .TRUE.
+C
+  820 CONTINUE ! chercher k2, le haut de la colonne
+      IF (k2 .EQ. klev) GOTO 821
+      k2p = k2 + 1
+      zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1))
+     .          *(local_q(i,k2p)-v_qs(i,k2p))
+      zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p)
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821
+      k2 = k2p
+      GOTO 820
+  821 CONTINUE
+C
+C------------------------------------------------------ ajustement local
+  830 CONTINUE ! ajustement proprement dit
+      v_cptj(k1) = 0.0
+      zdp = paprs(i,k1)-paprs(i,k1+1)
+      v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))
+     .               + RLVTT*(local_q(i,k1)-v_qs(i,k1)) ) * zdp
+      v_ssig = zdp * (1.0+v_qsd(i,k1))
+C
+      k1p = k1 + 1
+      DO k = k1p, k2
+         zdp = paprs(i,k)-paprs(i,k+1)
+         v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k)
+         v_cptjk1 = v_cptjk1 + zdp
+     .             * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k))
+     .               + RLVTT*(local_q(i,k)-v_qs(i,k)) )
+         v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k))
+      ENDDO
+C
+      DO k = k1, k2
+         cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
+         cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k)
+         new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT
+         local_q(i,k) = new_qb(k)
+         local_t(i,k) = cp_new_t(k) / RCPD
+      ENDDO
+C
+C--------------------------------------------------- sondage vers le bas
+C              -- on redefinit les variables prognostiques dans
+C              -- la colonne qui vient d'etre ajustee
+C
+      DO k = k1, k2
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+C
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      DO k = 2, klev
+         zdpm = paprs(i,k-1) - paprs(i,k)
+         zdp = paprs(i,k) - paprs(i,k+1)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) *
+     .                      (v_cptt(i,k-1)*zdpm+v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) *
+     .                      (v_qs(i,k-1)*zdpm+v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+v_qsd(i,k)*zdp)
+     .                      /(zdpm+zdp) )
+      ENDDO
+C
+C Verifier si l'on peut etendre la colonne vers le bas
+C
+      IF (k1 .EQ. 1) GOTO 841 ! extension echouee
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
+     .   + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee
+C
+  840 CONTINUE
+      k1 = k1 - 1
+      IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))
+     .             *(paprs(i,k1-1)-paprs(i,k1))
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN
+         GOTO 840
+      ELSE
+         GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      ENDIF
+  841 CONTINUE
+C
+      GOTO 810 ! chercher d'autres blocks en haut
+C
+ 9999 CONTINUE ! boucle sur tous les points
+C-----------------------------------------------------------------------
+c
+c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
+c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         delta_q(i,k) = local_q(i,k) - q(i,k)
+         IF (delta_q(i,k).LT.0.) rneb(i,k)  = 1.0
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
+c l'eau liquide est distribuee aux endroits ou la vapeur d'eau
+c diminue et d'une maniere proportionnelle a cet diminution):
+c
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zq1(i) = zq1(i) - delta_q(i,k) * zdp
+         zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp
+         ENDIF
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         IF (zq2(i).NE.0.0)
+     .      d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i)
+         ENDIF
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+          local_q(i, k) = MAX(local_q(i, k), seuil_vap)
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = local_t(i,k) - t(i,k)
+         d_q(i,k) = local_q(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE fiajc(dtime,paprs,pplay,
+     .                 t, q,conv_q,
+     .                 d_t, d_q, d_ql,rneb,
+     .                 rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT NONE
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Options:
+c
+      INTEGER plb ! niveau de depart pour la convection
+      PARAMETER (plb=4)
+c
+c Mystere: cette option n'est pas innocente pour les resultats !
+c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
+      LOGICAL vector ! calcul vectorise
+      PARAMETER (vector=.FALSE.)
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Arguments:
+c
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL t(klon,klev) ! temperature (K)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+      REAL dtime ! intervalle du temps (s)
+      REAL conv_q(klon,klev) ! taux de convergence de l'humidite
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL rain(klon) ! variable non-utilisee
+      REAL snow(klon) ! variable non-utilisee
+      INTEGER itop(klon) ! variable non-utilisee
+      INTEGER ibas(klon) ! variable non-utilisee
+c
+      INTEGER kh(klon), i, k
+      LOGICAL nuage(klon), test(klon,klev)
+      REAL zconv(klon), zdeh(klon,klev), zvirt(klon)
+      REAL zdqs(klon,klev), zqs(klon,klev)
+      REAL ztt, zvar, zfrac(klon)
+      REAL zq1(klon), zq2(klon)
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+          rneb(i,k) = 0.0
+          d_ql(i,k) = 0.0
+          d_t(i,k) = 0.0
+          d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         itop(i) = 0
+         ibas(i) = 0
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Calculer Qs et L/Cp * dQs/dT:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztt = t(i,k)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-ztt))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (ztt .LT. t_coup) THEN
+              zqs(i,k) = qsats(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsats(ztt,zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsatl(ztt,zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Determiner la difference de l'energie totale saturee:
+c
+      DO i = 1, klon
+         k = plb
+         zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie
+      ENDDO
+      DO k = plb+1, klev
+      DO i = 1, klon
+      zdeh(i,k) = zdeh(i,k-1)
+     .             + RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+      ENDDO
+      ENDDO
+c
+c Determiner le sommet du nuage selon l'instabilite
+c Calculer les convergences d'humidite (reelle et virtuelle)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i)  = k
+            zconv(i) = zconv(i)+conv_q(i,k)*dtime
+     .                         *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      IF (vector) THEN
+c
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+         test(i,k) = .TRUE.
+         zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+      ELSE
+         test(i,k) = .FALSE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+         zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+         zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                   * (paprs(i,k)-paprs(i,k+1))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      ELSE ! (.NOT. vector)
+c
+      DO 999 i = 1, klon
+      IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+ccc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
+ccc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
+         zfrac(i)  = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+         DO k = plb, kh(i)
+            zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+            d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .               - conv_q(i,k)*dtime
+            d_t(i,k) = zvar * zfrac(i) / RCPD
+         ENDDO
+c
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         DO k = plb, kh(i)
+            IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+            zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+            zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                      * (paprs(i,k)-paprs(i,k+1))
+         ENDDO
+         DO k = plb, kh(i)
+            IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+         ENDDO
+      ENDIF
+  999 CONTINUE
+c
+      ENDIF ! fin de teste sur vector
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/convect1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/convect1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/convect1.F	(revision 984)
@@ -0,0 +1,649 @@
+!
+! $Header$
+!
+      subroutine convect1(len,nd,ndp1,noff,minorig,
+     &                   t,q,qs,u,v,
+     &                   p,ph,iflag,ft,
+     &                   fq,fu,fv,precip,cbmf,delt,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect1.f	1.1 04/21/00
+C                       19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect1
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect1(len,nd,noff,minorig,
+C    &                   t,q,qs,u,v,
+C    &                   p,ph,iflag,ft,
+C    &                   fq,fu,fv,precip,cbmf,delt)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      noff          Integer        Input        integer limit for convection (nd-noff)
+C      minorig       Integer        Input        First level of convection
+C      t             Real           Input        temperature
+C      q             Real           Input        specific hum
+C      qs            Real           Input        sat specific hum
+C      u             Real           Input        u-wind
+C      v             Real           Input        v-wind
+C      p             Real           Input        full level pressure
+C      ph            Real           Input        half level pressure
+C      iflag         Integer        Output       iflag on latitude strip
+C      ft            Real           Output       temp tend
+C      fq            Real           Output       spec hum tend
+C      fu            Real           Output       u-wind tend
+C      fv            Real           Output       v-wind tend
+C      cbmf          Real           In/Out       cumulus mass flux
+C      delt          Real           Input        time step
+C      iflag         Integer        Output       integer flag for Emanuel conditions
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         convect2        Emanuel cumulus convection tendency calculations
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+       USE dimphy
+      implicit none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      real t(len,nd)
+      real q(len,nd)
+      real qs(len,nd)
+      real u(len,nd)
+      real v(len,nd)
+      real p(len,nd)
+      real ph(len,ndp1)
+      integer iflag(len)
+      real ft(len,nd)
+      real fq(len,nd)
+      real fu(len,nd)
+      real fv(len,nd)
+      real precip(len)
+      real cbmf(len)
+      real Ma(len,nd)
+      integer minorig
+      real delt,cpd,cpv,cl,rv,rd,lv0,g
+      real sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp
+      real alpha,entp,coeffs,coeffr,omtrain,cu
+c
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+      integer nl
+      integer nlp
+      integer nlm
+      integer i,k,n
+      real delti
+      real rowl
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real ginv
+      real hrd
+      real prccon1
+      integer icbmax
+      real lv(klon,klev)
+      real cpn(klon,klev)
+      real cpx(klon,klev)
+      real tv(klon,klev)
+      real gz(klon,klev)
+      real hm(klon,klev)
+      real h(klon,klev)
+      real work(klon)
+      integer ihmin(klon)
+      integer nk(klon)
+      real rh(klon)
+      real chi(klon)
+      real plcl(klon)
+      integer icb(klon)
+      real tnk(klon)
+      real qnk(klon)
+      real gznk(klon)
+      real pnk(klon)
+      real qsnk(klon)
+      real ticb(klon)
+      real gzicb(klon)
+      real tp(klon,klev)
+      real tvp(klon,klev)
+      real clw(klon,klev)
+c
+      real ah0(klon),cpp(klon)
+      real tg,qg,s,alv,tc,ahg,denom,es,rg
+c
+      integer ncum
+      integer idcum(klon)
+c
+      cpd=1005.7
+      cpv=1870.0
+      cl=4190.0
+      rv=461.5
+      rd=287.04
+      lv0=2.501E6
+      g=9.8
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+      sigs=0.12
+      sigd=0.05
+      elcrit=0.0011
+      tlcrit=-55.0
+      omtsnow=5.5
+      dtmax=0.9
+      damp=0.1
+      alpha=0.2
+      entp=1.5
+      coeffs=0.8
+      coeffr=1.0
+      omtrain=50.0
+c
+      cu=0.70
+      damp=0.1
+c
+c
+c Define nl, nlp, nlm, and delti
+c
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+      delti=1.0/delt
+!
+!-------------------------------------------------------------------
+! --- SET CONSTANTS
+!-------------------------------------------------------------------
+!
+      rowl=1000.0
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+      ginv=1.0/g
+      hrd=0.5*rd
+      prccon1=86400.0*1000.0/(rowl*g)
+!
+! dtmax is the maximum negative temperature perturbation.
+!
+!=====================================================================
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!=====================================================================
+!
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft(i,k)=0.0
+         fq(i,k)=0.0
+         fu(i,k)=0.0
+         fv(i,k)=0.0
+         tvp(i,k)=0.0
+         tp(i,k)=0.0
+         clw(i,k)=0.0
+         gz(i,k) = 0.
+ 10     continue
+ 20   continue
+      do 60 i=1,len
+        precip(i)=0.0
+        iflag(i)=0
+ 60   continue
+c
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+      do 110 k=1,nl+1
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+c
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+!
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+!
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+c
+      ncum=0
+      do 400 i=1,len
+        if(iflag(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+c
+c Call convect2, which compresses the points and computes the heating,
+c moistening, velocity mixing, and precipiation.
+c
+c     print*,'cpd avant convect2 ',cpd
+      if(ncum.gt.0)then
+      call convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &              nk,icb,
+     &              t,q,qs,u,v,gz,tv,tp,tvp,clw,h,
+     &              lv,cpn,p,ph,ft,fq,fu,fv,
+     &              tnk,qnk,gznk,plcl,
+     &              precip,cbmf,iflag,
+     &              delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &              sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &              alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+      endif
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/convect2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/convect2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/convect2.F	(revision 984)
@@ -0,0 +1,1395 @@
+!
+! $Header$
+!
+      subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &                 nk1,icb1,
+     &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+     &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+     &                 tnk1,qnk1,gznk1,plcl1,
+     &                 precip1,cbmf1,iflag1,
+     &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &                 alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect2.f	1.2 05/18/00
+C                       22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect2
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme - compute tendencies
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect2(ncum,idcum,len,nd,nl,minorig,
+C    &                 nk1,icb1,
+C    &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+C    &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+C    &                 tnk1,qnk1,gznk1,plcl1,
+C    &                 precip1,cbmf1,iflag1,
+C    &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+C    &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+C    &                 alpha,entp,coeffs,coeffr,omtrain,cu)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      ncum          Integer        Input        number of cumulus points
+C      idcum         Integer        Input        index of cumulus point
+C      len           Integer        Input        first dimension
+C      nd            Integer        Input        total vertical dimension
+C      ndp1          Integer        Input        nd + 1
+C      nl            Integer        Input        vertical dimension for convection
+C      minorig       Integer        Input        First level where convection is allow to begin
+C      nk1           Integer        Input        First level of convection
+C      ncb1          Integer        Input        Level of free convection
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      gz1           Real           Inout        geop
+C      tv1           Real           Input        virtual temp
+C      tp1           Real           Input
+C      clw1          Real           Inout        cloud liquid water
+C      h1            Real           Inout
+C      lv1           Real           Inout
+C      cpn1          Real           Inout
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      precip1       Real           Output       prec
+C      cbmf1         Real           In/Out       cumulus mass flux
+C      iflag1        Integer        Output       iflag on latitude strip
+C      delt          Real           Input        time step
+C      cpd           Integer        Input        See description below
+C      cpv           Integer        Input        See description below
+C      cl            Integer        Input        See description below
+C      rv            Integer        Input        See description below
+C      rd            Integer        Input        See description below
+C      lv0           Integer        Input        See description below
+C      g             Integer        Input        See description below
+C      sigs          Integer        Input        See description below
+C      sigd          Integer        Input        See description below
+C      elcrit        Integer        Input        See description below
+C      tlcrit        Integer        Input        See description below
+C      omtsnow       Integer        Input        See description below
+C      dtmax         Integer        Input        See description below
+C      damp          Integer        Input        See description below
+C      alpha         Integer        Input        See description below
+C      ent           Integer        Input        See description below
+C      coeffs        Integer        Input        See description below
+C      coeffr        Integer        Input        See description below
+C      omtrain       Integer        Input        See description below
+C      cu            Integer        Input        See description below
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         zilch        Zero out an array
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+      USE dimphy
+      implicit none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer kmax2,imax2,kmin2,imin2
+      real ftmax2,ftmin2
+      integer kmax,imax,kmin,imin
+      real ftmax,ftmin
+c
+      integer ncum
+      integer idcum(len)
+      integer len
+      integer nd
+      integer ndp1
+      integer nl
+      integer minorig
+      integer nk1(len)
+      integer icb1(len)
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real gz1(len,nd)
+      real tv1(len,nd)
+      real tp1(len,nd)
+      real tvp1(len,nd)
+      real clw1(len,nd)
+      real h1(len,nd)
+      real lv1(len,nd)
+      real cpn1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real tnk1(len)
+      real qnk1(len)
+      real gznk1(len)
+      real precip1(len)
+      real cbmf1(len)
+      real plcl1(len)
+      integer iflag1(len)
+      real delt
+      real cpd
+      real cpv
+      real cl
+      real rv
+      real rd
+      real lv0
+      real g
+      real sigs    ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE
+      real sigd    ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT
+      real elcrit  ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm)
+      real tlcrit  ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-
+c                     CONVERSION THRESHOLD IS ASSUMED TO BE ZERO
+      real omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW
+      real dtmax   ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
+c                    A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC.
+      real damp
+      real alpha
+      real entp    ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION
+      real coeffs  ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF SNOW
+      real coeffr  ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF RAIN
+      real omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN
+      real cu      ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT
+c
+      real Ma(len,nd)
+c
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+c Local arrays.
+c
+      real work(ncum)
+      real t(ncum,klev)
+      real q(ncum,klev)
+      real qs(ncum,klev)
+      real u(ncum,klev)
+      real v(ncum,klev)
+      real gz(ncum,klev)
+      real h(ncum,klev)
+      real lv(ncum,klev)
+      real cpn(ncum,klev)
+      real p(ncum,klev)
+      real ph(ncum,klev)
+      real ft(ncum,klev)
+      real fq(ncum,klev)
+      real fu(ncum,klev)
+      real fv(ncum,klev)
+      real precip(ncum)
+      real cbmf(ncum)
+      real plcl(ncum)
+      real tnk(ncum)
+      real qnk(ncum)
+      real gznk(ncum)
+      real tv(ncum,klev)
+      real tp(ncum,klev)
+      real tvp(ncum,klev)
+      real clw(ncum,klev)
+c     real det(ncum,klev)
+      real dph(ncum,klev)
+c     real wd(ncum)
+c     real tprime(ncum)
+c     real qprime(ncum)
+      real ah0(ncum)
+      real ep(ncum,klev)
+      real sigp(ncum,klev)
+      integer nent(ncum,klev)
+      real water(ncum,klev)
+      real evap(ncum,klev)
+      real mp(ncum,klev)
+      real m(ncum,klev)
+      real qti
+      real wt(ncum,klev)
+      real hp(ncum,klev)
+      real lvcp(ncum,klev)
+      real elij(ncum,klev,klev)
+      real ment(ncum,klev,klev)
+      real sij(ncum,klev,klev)
+      real qent(ncum,klev,klev)
+      real uent(ncum,klev,klev)
+      real vent(ncum,klev,klev)
+      real qp(ncum,klev)
+      real up(ncum,klev)
+      real vp(ncum,klev)
+      real cape(ncum)
+      real capem(ncum)
+      real frac(ncum)
+      real dtpbl(ncum)
+      real tvpplcl(ncum)
+      real tvaplcl(ncum)
+      real dtmin(ncum)
+      real w3d(ncum,klev)
+      real am(ncum)
+      real ents(ncum)
+      real uav(ncum)
+      real vav(ncum)
+c
+      integer iflag(ncum)
+      integer nk(ncum)
+      integer icb(ncum)
+      integer inb(ncum)
+      integer inb1(ncum)
+      integer jtt(ncum)
+c
+      integer nn,i,k,n,icbmax,nlp,j
+      integer ij
+      integer nn2,nn3
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real tg,qg,s,alv,tc,ahg,denom,es,rg,ginv,rowl
+      real delti
+      real tca,elacrit
+      real by,defrac
+c     real byp
+      real byp(ncum)
+      logical lcape(ncum)
+      real dbo
+      real bf2,anum,dei,altem,cwat,stemp
+      real alt,qp1,smid,sjmax,sjmin
+      real delp,delm
+      real awat,coeff,afac,revap,dhdp,fac,qstm,rat
+      real qsm,sigt,b6,c6
+      real dpinv,cpinv
+      real fqold,ftold,fuold,fvold
+      real wdtrain(ncum),xxx
+      real bsum(ncum,klev)
+      real asij(ncum)
+      real smin(ncum)
+      real scrit(ncum)
+c     real amp1,ad
+      real amp1(ncum),ad(ncum)
+      logical lwork(ncum)
+      integer num1,num2
+c
+c     print*,'cpd en entree de convect2 ',cpd
+      nlp=nl+1
+c
+      rowl=1000.0
+      ginv=1.0/g
+      delti=1.0/delt
+c
+c Define some thermodynamic variables.
+c
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c
+c Compress the fields.
+c
+      do 110 k=1,nl+1
+       nn=0
+	do 100 i=1,len
+	  if(iflag1(i).eq.0)then
+	    nn=nn+1
+	    t(nn,k)=t1(i,k)
+	    q(nn,k)=q1(i,k)
+	    qs(nn,k)=qs1(i,k)
+	    u(nn,k)=u1(i,k)
+	    v(nn,k)=v1(i,k)
+	    gz(nn,k)=gz1(i,k)
+	    h(nn,k)=h1(i,k)
+	    lv(nn,k)=lv1(i,k)
+	    cpn(nn,k)=cpn1(i,k)
+	    p(nn,k)=p1(i,k)
+	    ph(nn,k)=ph1(i,k)
+	    tv(nn,k)=tv1(i,k)
+	    tp(nn,k)=tp1(i,k)
+	    tvp(nn,k)=tvp1(i,k)
+	    clw(nn,k)=clw1(i,k)
+	  endif
+ 100    continue
+c       print*,'100 ncum,nn',ncum,nn
+ 110  continue
+      nn=0
+      do 150 i=1,len
+	if(iflag1(i).eq.0)then
+	  nn=nn+1
+	  cbmf(nn)=cbmf1(i)
+	  plcl(nn)=plcl1(i)
+	  tnk(nn)=tnk1(i)
+	  qnk(nn)=qnk1(i)
+	  gznk(nn)=gznk1(i)
+	  nk(nn)=nk1(i)
+	  icb(nn)=icb1(i)
+	  iflag(nn)=iflag1(i)
+	endif
+ 150  continue
+c       print*,'150 ncum,nn',ncum,nn
+c
+c Initialize the tendencies, det, wd, tprime, qprime.
+c
+      do 170 k=1,nl
+	do 160 i=1,ncum
+c         det(i,k)=0.0
+	  ft(i,k)=0.0
+	  fu(i,k)=0.0
+	  fv(i,k)=0.0
+	  fq(i,k)=0.0
+	  dph(i,k)=ph(i,k)-ph(i,k+1)
+	  ep(i,k)=0.0
+	  sigp(i,k)=sigs
+ 160    continue
+ 170  continue
+      do 180 i=1,ncum
+c      wd(i)=0.0
+c      tprime(i)=0.0
+c      qprime(i)=0.0
+       precip(i)=0.0
+       ft(i,nl+1)=0.0
+       fu(i,nl+1)=0.0
+       fv(i,nl+1)=0.0
+       fq(i,nl+1)=0.0
+ 180  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 230 i=1,ncum
+	icbmax=max(icbmax,icb(i))
+ 230  continue
+c
+c
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+	ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+	       tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)
+     &                  /cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-273.15
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c
+c=====================================================================
+c --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          water(i,1)=0.0
+          evap(i,1)=0.0
+          mp(i,1)=0.0
+          m(i,1)=0.0
+          wt(i,1)=omtsnow
+          hp(i,1)=h(i,1)
+c         if(.not.cpn(i,1).gt.900.) then
+c         print*,'i,lv(i,1),cpn(i,1)'
+c         print*, i,lv(i,1),cpn(i,1)
+c         k=(i-1)/ncum+1
+c         print*,'i,k',mod(i,ncum),k,'  cpn',cpn(mod(i,ncum),k)
+c         stop
+c         endif
+          lvcp(i,1)=lv(i,1)/cpn(i,1)
+ 360    continue
+c
+      do 380 i=1,ncum*nlp*nlp
+        elij(i,1,1)=0.0
+        ment(i,1,1)=0.0
+        sij(i,1,1)=0.0
+ 380  continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+ 385      continue
+ 390    continue
+ 400  continue
+c
+      do 420 i=1,ncum
+        qp(i,1)=q(i,1)
+        up(i,1)=u(i,1)
+        vp(i,1)=v(i,1)
+ 420  continue
+      do 440 k=2,nlp
+        do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430    continue
+ 440  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),
+c --- AT EACH MODEL LEVEL
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+c
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+c     wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
+c     qprime=0.5*(qp(1)-q(1))
+c     tprime=lv0*qprime/cpd
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+           endif
+ 1910    continue
+ 1920   continue
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+ 2010     continue
+ 2020   continue
+c
+      DO k=1,nd
+        DO i=1,len
+         Ma(i,k) = 0.
+        ENDDO
+      ENDDO
+      DO k=nl,1,-1
+        DO i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        ENDDO
+      ENDDO
+c
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/convect3.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/convect3.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/convect3.F	(revision 984)
@@ -0,0 +1,1408 @@
+!
+! $Header$
+!
+      SUBROUTINE CONVECT3	
+     *    (DTIME,EPMAX,ok_adj,
+     *     T1,   R1,   RS,    U,  V,  TRA,   P,     PH,
+     *     ND,       NDP1,     NL, NTRA,  DELT,  IFLAG,
+     *     FT, FR, FU,  FV,  FTRA,  PRECIP,
+     *     icb,inb,   upwd,dnwd,dnwd0,SIG, W0,Mike,Mke,
+     *     Ma,MENTS,QENTS,TPS,TLS,SIGIJ,CAPE,TVP,PBASE,BUOYBASE,
+cccc     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
+     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR,   ! sbl
+     *     FT2,FR2,FU2,FV2,WD,QCOND,QCONDC)   ! sbl
+C
+C    ***  THE PARAMETER NA SHOULD IN GENERAL EQUAL ND   ***
+C
+c#################################################################
+cFleur       Introduction des traceurs dans convect3 le 6 juin 200
+c#################################################################
+      USE dimphy
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+      PARAMETER (NA=60)
+
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+      REAL DELTAC              ! cld
+      PARAMETER (DELTAC=0.01)  ! cld
+
+      INTEGER NENT(NA)
+      REAL T1(ND),R1(ND),RS(ND),U(ND),V(ND),TRA(ND,NTRA)
+      REAL P(ND),PH(NDP1)
+      REAL FT(ND),FR(ND),FU(ND),FV(ND),FTRA(ND,NTRA)
+      REAL SIG(ND),W0(ND)
+      REAL UENT(NA,NA),VENT(NA,NA),TRAENT(NA,NA,NTRAC),TRATM(NA)
+      REAL UP(NA),VP(NA),TRAP(NA,NTRAC)
+      REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
+      REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
+      REAL RP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
+      REAL SIGP(NA),B(NA),TP(NA),CPN(NA)
+      REAL LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA)
+      REAL T(NA),RR(NA)
+C
+      REAL FT2(ND),FR2(ND),FU2(ND),FV2(ND) ! added sbl
+      REAL U1(ND),V1(ND) ! added sbl
+C
+      REAL BUOY(NA)     !  Lifted parcel buoyancy
+      REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                      temperature wrt T1 and Q1
+      REAL CLW_NEW(NA),QI(NA)
+C
+      REAL WD, BETAD ! for gust factor (sb)
+      REAL QCONDC(ND)  ! interface cld param (sb)
+      REAL QCOND(ND),NQCOND(NA),WA(NA),MAA(NA),SIGA(NA),AXC(NA) ! cld
+C
+      LOGICAL ICE_CONV,ok_adj
+      PARAMETER (ICE_CONV=.TRUE.)
+ 
+cccccccccccccccccccccccccccccccccccccccccccccc
+c     declaration des variables a sortir
+ccccccccccccccccccccccccccccccccccccccccccccc
+      real Mke(nd)
+      real Mike(nd)
+      real Ma(nd)
+      real TPS(ND) !temperature dans les ascendances non diluees
+      real TLS(ND) !temperature potentielle
+      real MENTS(nd,nd)
+      real QENTS(nd,nd)
+      REAL SIGIJ(KLEV,KLEV)
+      REAL PBASE ! pressure at the cloud base level
+      REAL BUOYBASE ! buoyancy at the cloud base level
+cccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+ 
+c
+      real dnwd0(nd)  !  precipitation driven unsaturated downdraft flux
+      real dnwd(nd), dn1  ! in-cloud saturated downdraft mass flux
+      real upwd(nd), up1  ! in-cloud saturated updraft mass flux
+C
+C   ***         ASSIGN VALUES OF THERMODYNAMIC CONSTANTS        ***
+C   ***             THESE SHOULD BE CONSISTENT WITH             ***
+C   ***              THOSE USED IN CALLING PROGRAM              ***
+C   ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
+C
+c sb      CPD=1005.7
+c sb      CPV=1870.0
+c sb      CL=4190.0
+c sb      CPVMCL=CL-CPV
+c sb      RV=461.5
+c sb      RD=287.04
+c sb      EPS=RD/RV
+c sb      ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CPVMCL=CL-CPV
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+cccccccccccccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+       NK = 1 ! origin level of the lifted parcel
+c
+cccccccccccccccccccccc
+C
+C           ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
+C
+      DO 5 I=1,ND
+         FT(I)=0.0
+         FR(I)=0.0
+         FU(I)=0.0
+         FV(I)=0.0
+
+         FT2(I)=0.0
+         FR2(I)=0.0
+         FU2(I)=0.0
+         FV2(I)=0.0
+
+         DO 4 J=1,NTRA
+          FTRA(I,J)=0.0
+    4    CONTINUE
+
+         QCONDC(I)=0.0  ! cld
+         QCOND(I)=0.0   ! cld
+         NQCOND(I)=0.0  ! cld
+
+         T(I)=T1(I)
+         RR(I)=R1(I)
+         U1(I)=U(I) ! added sbl
+         V1(I)=V(I) ! added sbl
+    5 CONTINUE
+      DO 7 I=1,NL
+         RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+         TH(I)=T(I)*(1000.0/P(I))**RDCP
+    7 CONTINUE
+C
+*************************************************************
+**    CALCUL DES TEMPERATURES POTENTIELLES A SORTIR
+*************************************************************
+      do i=1,ND
+      RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+ 
+      TLS(i)=T(I)*(1000.0/P(I))**RDCP
+      enddo
+ 
+ 
+ 
+ 
+************************************************************
+ 
+ 
+      PRECIP=0.0
+      WD=0.0 ! sb
+      IFLAG=1
+C
+C   ***                    SPECIFY PARAMETERS                        ***
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE   ***
+C   ***       PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO         ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP.      ***
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY                 ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE      ***
+C   ***                        OF CLOUD                              ***
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY)    ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)             ***
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***                     IT MUST BE LESS THAN 0                   ***
+C
+      PBCRIT=150.0
+      PTCRIT=500.0
+      SIGD=0.01
+      SPFAC=0.15
+c sb:
+c     EPMAX=0.993 ! precip efficiency less than unity
+c      EPMAX=1. ! precip efficiency less than unity
+C
+Cjyg
+CCC      BETA=0.96
+C  Beta is now expressed as a function of the characteristic time
+C  of the convective process.
+CCC        Old value : TAU = 15000.   !(for dtime = 600.s)
+CCC        Other value (inducing little change) :TAU = 8000.
+      TAU = 8000.
+      BETA = 1.-DTIME/TAU
+Cjyg
+CCC      ALPHA=1.0
+      ALPHA=1.5E-3*DTIME/TAU
+C        Increase alpha in order to compensate W decrease
+      ALPHA = ALPHA*1.5
+C
+Cjyg (voir CONVECT 3)
+CCC      DTCRIT=-0.2
+      DTCRIT=-2.
+Cgf&jyg
+CCC     DT pour l'overshoot.
+      DTOVSH = -0.2
+ 
+C
+C           ***        INCREMENT THE COUNTER       ***
+C
+      SIG(ND)=SIG(ND)+1.0
+      SIG(ND)=AMIN1(SIG(ND),12.1)
+C
+C           ***    IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT     ***
+C           ***     RETURNS ARRAYS T AND R THAT MAY HAVE BEEN      ***
+C           ***  ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE    ***
+C           ***        THE RETURNED ARRAYS ARE UNALTERED.          ***
+C
+      NOPT=0
+c!      NOPT=1 ! sbl
+C
+C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
+C
+C     ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
+C     ***                BOUNDARY LAYER SCHEME !!!               ***
+C
+      IF (ok_adj) THEN ! added sbl
+
+      DO 30 I=NL-1,1,-1
+         JN=0
+         DO 10 J=I+1,NL
+   10    IF(TH(J).LT.TH(I))JN=J
+         IF(JN.EQ.0)GOTO 30
+         AHM=0.0
+         RM=0.0
+         UM=0.0
+         VM=0.0
+         DO K=1,NTRA
+          TRATM(K)=0.0
+         END DO
+         DO 15 J=I,JN
+          AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1))
+          RM=RM+RR(J)*(PH(J)-PH(J+1))
+          UM=UM+U(J)*(PH(J)-PH(J+1))
+          VM=VM+V(J)*(PH(J)-PH(J+1))
+          DO K=1,NTRA
+           TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1))
+          END DO
+   15    CONTINUE
+         DPHINV=1./(PH(I)-PH(JN+1))
+         RM=RM*DPHINV
+         UM=UM*DPHINV
+         VM=VM*DPHINV
+         DO K=1,NTRA
+          TRATM(K)=TRATM(K)*DPHINV
+         END DO
+         A2=0.0
+         DO 20 J=I,JN
+            RR(J)=RM
+          U(J)=UM
+          V(J)=VM
+          DO K=1,NTRA
+           TRA(J,K)=TRATM(K)
+          END DO
+            RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV)
+            X=(0.001*P(J))**RDCP
+            T(J)=X
+            A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1))
+   20    CONTINUE
+         DO 25 J=I,JN
+            TH(J)=AHM/A2
+            T(J)=T(J)*TH(J)
+   25    CONTINUE
+   30 CONTINUE
+
+      ENDIF ! added sbl
+C
+C   ***   RESET INPUT ARRAYS IF ok_adj 0   ***
+C
+      IF (ok_adj)THEN
+         DO 35 I=1,ND
+
+           FT2(I)=(T(I)-T1(I))/DELT  ! sbl
+           FR2(I)=(RR(I)-R1(I))/DELT  ! sbl
+           FU2(I)=(U(I)-U1(I))/DELT  ! sbl
+           FV2(I)=(V(I)-V1(I))/DELT  ! sbl
+
+c!            T1(I)=T(I)      ! commente sbl
+c!            R1(I)=RR(I)     ! commente sbl
+   35    CONTINUE
+      END IF
+C
+C  *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+C
+      GZ(1)=0.0
+      CPN(1)=CPD*(1.-RR(1))+RR(1)*CPV
+      H(1)=T(1)*CPN(1)
+      DO 40 I=2,NL
+        TVX=T(I)*(1.+RR(I)/EPS-RR(I))
+        TVY=T(I-1)*(1.+RR(I-1)/EPS-RR(I-1))
+        GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I)
+        CPN(I)=CPD*(1.-RR(I))+CPV*RR(I)
+        H(I)=T(I)*CPN(I)+GZ(I)
+   40 CONTINUE
+C
+C   ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL ***
+C   ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)     ***
+C
+      IF (T(1).LT.250.0.OR.RR(1).LE.0.0)THEN
+         IFLAG=0
+c sb3d         print*,'je suis passe par 366'
+         RETURN
+      END IF
+
+cjyg1 Utilisation de la subroutine CLIFT
+CC      RH=RR(1)/RS(1)
+CC      CHI=T(1)/(1669.0-122.0*RH-T(1))
+CC      PLCL=P(1)*(RH**CHI)
+      CALL CLIFT(P(1),T(1),RR(1),RS(1),PLCL,DPLCLDT,DPLCLDR)
+cjyg2
+c sb3d      PRINT *,' em_plcl,p1,t1,r1,rs1,rh '
+c sb3d     $        ,PLCL,P(1),T(1),RR(1),RS(1),RH
+c
+      IF (PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+         IFLAG=2
+         RETURN
+      END IF
+Cjyg1
+C     Essais de modification de ICB
+C
+C   ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
+C
+CC      ICB=NL-1
+CC      DO 50 I=2,NL-1
+CC         IF(P(I).LT.PLCL)THEN
+CC            ICB=MIN(ICB,I)   ! ICB sup ou egal a 2
+CC         END IF
+CC   50 CONTINUE
+CC      IF(ICB.EQ.(NL-1))THEN
+CC         IFLAG=3
+CC         RETURN
+CC      END IF
+C
+C   *** CALCULATE LAYER CONTAINING LCL (=ICB)   ***
+C
+      ICB=NL-1
+c sb      DO 50 I=2,NL-1
+      DO 50 I=3,NL-1 ! modif sb pour que ICB soit sup/egal a 2
+C   la modification consiste a comparer PLCL a PH et non a P:
+C   ICB est defini par :  PH(ICB)<PLCL<PH(ICB-!)
+         IF(PH(I).LT.PLCL)THEN
+            ICB=MIN(ICB,I)
+         END IF
+   50 CONTINUE
+      IF(ICB.EQ.(NL-1))THEN
+         IFLAG=3
+         RETURN
+      END IF
+      ICB = ICB-1 ! ICB sup ou egal a 2 
+Cjyg2
+C
+C
+ 
+C   *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL      ***
+C   ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC             ***
+C   ***                   LIQUID WATER CONTENT                             ***
+C
+ 
+cjyg1
+c make sure that "Cloud base" seen by TLIFT is actually the 
+c fisrt level where adiabatic ascent is saturated 
+       IF (PLCL .GT. P(ICB)) THEN
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ELSE
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ENDIF
+cjyg2
+ 
+******************************************************************************
+****     SORTIE DE LA TEMPERATURE DE L ASCENDANCE NON DILUE
+******************************************************************************
+        do i=1,ND
+        TPS(i)=TP(i)
+        enddo
+ 
+ 
+******************************************************************************
+ 
+C
+C   ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
+C   ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
+C   ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
+C
+      DO 55 I=1,NL
+         PDEN=PTCRIT-PBCRIT
+c
+cjyg
+ccc         EP(I)=(P(ICB)-P(I)-PBCRIT)/PDEN
+c sb         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN
+         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN * EPMAX ! sb
+c
+         EP(I)=AMAX1(EP(I),0.0)
+c sb         EP(I)=AMIN1(EP(I),1.0)
+         EP(I)=AMIN1(EP(I),EPMAX) ! sb
+         SIGP(I)=SPFAC
+C
+C   ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
+C   ***                    VIRTUAL TEMPERATURE                    ***
+C
+         TV(I)=T(I)*(1.+RR(I)/EPS-RR(I))
+Ccd1
+C    . Keep all liquid water in lifted parcel (-> adiabatic CAPE)
+C
+ccc    TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I))
+c!!! sb         TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift
+Ccd2
+C
+C   ***       Calculate first estimate of buoyancy
+C
+         BUOY(I) = TVP(I) - TV(I)
+   55 CONTINUE
+C
+C   ***   Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy
+C
+      DPBASE = -40.   !That is 400m above LCL
+      PBASE = PLCL + DPBASE
+      TVPBASE = TVP(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $         +TVP(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+      TVBASE = TV(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $        +TV(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+C
+c test sb:
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c@      write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1)
+c@     :             ,tv(icb),tv(icb1)'
+c@      write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb)
+c@     L          ,tvp(icb+1),tv(icb),tv(icb+1)
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c fin test sb
+      BUOYBASE = TVPBASE - TVBASE
+C
+CC       Set buoyancy = BUOYBASE for all levels below BASE.
+CC       For safety, set : BUOY(ICB) = BUOYBASE
+      DO I = ICB,NL
+        IF (P(I) .GE. PBASE) THEN
+          BUOY(I) = BUOYBASE
+        ENDIF
+      ENDDO
+      BUOY(ICB) = BUOYBASE
+C
+c sb3d      print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl'
+c sb3d     $,        buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl
+c sb3d      print *,'TVP ',(tvp(i),i=1,nl)
+c sb3d      print *,'TV ',(tv(i),i=1,nl)
+c sb3d      print *, 'P ',(p(i),i=1,nl)
+c sb3d      print *,'ICB ',icb
+c test sb:
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c@      write(*,*) 'icb,icbs,inb,buoybase:'
+c@      write(*,*) icb,icb+1,inb,buoybase
+c@      write(*,*) 'k,tvp,tv,tp,buoy,ep: '
+c@      do k=1,nl
+c@      write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k)
+c@      enddo
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c fin test sb
+
+
+C
+C   ***   MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE  ***
+C   ***    AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT  ***
+C   ***                         AT CLOUD BASE                         ***
+C   ***       IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING       ***
+C   ***                        SIG(I) AND W0(I)                       ***
+C
+Cjyg
+CCC      TDIF=TVP(ICB)-TV(ICB)
+      TDIF = BUOY(ICB)
+      ATH1=TH(1)
+Cjyg
+CCC      ATH=TH(ICB-1)-1.0
+      ATH=TH(ICB-1)-5.0
+c      ATH=0.                          ! ajout sb
+c      IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb
+      IF(TDIF.LT.DTCRIT.OR.ATH.GT.ATH1)THEN
+         DO 60 I=1,NL
+            SIG(I)=BETA*SIG(I)-2.*ALPHA*TDIF*TDIF
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   60    CONTINUE
+         IFLAG=0
+         RETURN
+      END IF
+C
+ 
+ 
+C   ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
+C   ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS       ***
+C
+      DO 70 I=1,NL
+         HP(I)=H(I)
+         WT(I)=0.001
+         RP(I)=RR(I)
+         UP(I)=U(I)
+         VP(I)=V(I)
+         DO 71 J=1,NTRA
+          TRAP(I,J)=TRA(I,J)
+   71    CONTINUE
+         NENT(I)=0
+         WATER(I)=0.0
+         EVAP(I)=0.0
+         B(I)=0.0
+         MP(I)=0.0
+         M(I)=0.0
+         LV(I)=ALV0-CPVMCL*(T(I)-273.15)
+         LVCP(I)=LV(I)/CPN(I)
+         DO 70 J=1,NL
+            QENT(I,J)=RR(J)
+            ELIJ(I,J)=0.0
+            MENT(I,J)=0.0
+            SIJ(I,J)=0.0
+          UENT(I,J)=U(J)
+          VENT(I,J)=V(J)
+          DO 70 K=1,NTRA
+           TRAENT(I,J,K)=TRA(J,K)
+   70 CONTINUE
+ 
+      DELTI=1.0/DELT
+C
+C  ***  FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S       ***
+C  ***                LEVEL OF NEUTRAL BUOYANCY                   ***
+C
+      INB=NL-1
+      DO 80 I=ICB,NL-1
+Cjyg
+CCC         IF((TVP(I)-TV(I)).LT.DTCRIT)THEN
+         IF(BUOY(I).LT.DTOVSH)THEN
+            INB=MIN(INB,I)
+         END IF
+   80 CONTINUE
+ 
+ 
+ 
+ 
+C
+C   ***          RESET SIG(I) AND W0(I) FOR I>INB AND I<ICB       ***
+C
+      IF(INB.LT.(NL-1))THEN
+         DO 85 I=INB+1,NL-1
+Cjyg
+CCC            SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(INB)-TVP(INB))*
+CCC     1              ABS(TV(INB)-TVP(INB))
+            SIG(I)=BETA*SIG(I)+2.*ALPHA*BUOY(INB)*
+     1              ABS(BUOY(INB))
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   85    CONTINUE
+      END IF
+      DO 87 I=1,ICB
+Cjyg
+CCC         SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(ICB)-TVP(ICB))*
+CCC     1           (TV(ICB)-TVP(ICB))
+         SIG(I)=BETA*SIG(I)-2.*ALPHA*BUOY(ICB)*BUOY(ICB)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         W0(I)=BETA*W0(I)
+   87 CONTINUE
+C
+C   ***    RESET FRACTIONAL AREAS OF UPDRAFTS AND W0 AT INITIAL TIME    ***
+C   ***           AND AFTER 10 TIME STEPS OF NO CONVECTION              ***
+C
+ 
+      IF(SIG(ND).LT.1.5.OR.SIG(ND).GT.12.0)THEN
+         DO 90 I=1,NL-1
+            SIG(I)=0.0
+            W0(I)=0.0
+   90    CONTINUE
+      END IF
+C
+C   ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
+C
+      DO 95 I=ICB,INB
+         HP(I)=H(1)+(LV(I)+(CPD-CPV)*T(I))*EP(I)*CLW(I)
+   95 CONTINUE
+C
+C   ***  CALCULATE CONVECTIVE AVAILABLE POTENTIAL ENERGY (CAPE),  ***
+C   ***     VERTICAL VELOCITY (W), FRACTIONAL AREA COVERED BY     ***
+C   ***     UNDILUTE UPDRAFT (SIG),  AND UPDRAFT MASS FLUX (M)    ***
+C
+      CAPE=0.0
+C
+      DO 98 I=ICB+1,INB
+Cjyg1
+CCC         CAPE=CAPE+RD*(TVP(I-1)-TV(I-1))*(PH(I-1)-PH(I))/P(I-1)
+CCC         DCAPE=RD*BUOY(I-1)*(PH(I-1)-PH(I))/P(I-1)
+CCC         DLNP=(PH(I-1)-PH(I))/P(I-1)
+C          The interval on which CAPE is computed starts at PBASE :
+         DELTAP = MIN(PBASE,PH(I-1))-MIN(PBASE,PH(I))
+         CAPE=CAPE+RD*BUOY(I-1)*DELTAP/P(I-1)
+         DCAPE=RD*BUOY(I-1)*DELTAP/P(I-1)
+         DLNP=DELTAP/P(I-1)
+Cjyg2
+c sb3d         print *,'buoy,dlnp,dcape,cape',buoy(i-1),dlnp,dcape,cape
+c test sb:
+c@       write(*,*) '############################################'
+c@         write(*,*) 'cape,rrd,buoy,deltap,p,pbase,ph:'
+c@     :     ,cape,rd,buoy(i-1),deltap,p(i-1),pbase,ph(i)
+c@       write(*,*) '############################################'
+
+c fin test sb
+         CAPE=AMAX1(0.0,CAPE)
+C
+         SIGOLD=SIG(I)
+         DTMIN=100.0
+         DO 97 J=ICB,I-1
+Cjyg
+CCC            DTMIN=AMIN1(DTMIN,(TVP(J)-TV(J)))
+            DTMIN=AMIN1(DTMIN,BUOY(J))
+   97    CONTINUE
+c sb3d     print *, 'DTMIN, BETA, ALPHA, SIG = ',DTMIN,BETA,ALPHA,SIG(I)
+         SIG(I)=BETA*SIG(I)+ALPHA*DTMIN*ABS(DTMIN)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         SIG(I)=AMIN1(SIG(I),0.01)
+         FAC=AMIN1(((DTCRIT-DTMIN)/DTCRIT),1.0)
+Cjyg
+CC    Essais de reduction de la vitesse
+CC         FAC = FAC*.5
+C
+         W=(1.-BETA)*FAC*SQRT(CAPE)+BETA*W0(I)
+         AMU=0.5*(SIG(I)+SIGOLD)*W
+         M(I)=AMU*0.007*P(I)*(PH(I)-PH(I+1))/TV(I)
+
+c --------- test sb:
+c       write(*,*) '############################################'
+c       write(*,*) 'k,amu,buoy(k-1),deltap,w,beta,fac,cape,w0(k)'
+c       write(*,*) i,amu,buoy(i-1),deltap
+c     :           ,w,beta,fac,cape,w0(i)
+c       write(*,*) '############################################'
+c ---------
+
+         W0(I)=W
+   98 CONTINUE
+      W0(ICB)=0.5*W0(ICB+1)
+      M(ICB)=0.5*M(ICB+1)*(PH(ICB)-PH(ICB+1))/(PH(ICB+1)-PH(ICB+2))
+      SIG(ICB)=SIG(ICB+1)
+      SIG(ICB-1)=SIG(ICB)
+cjyg1
+c sb3d      print *, 'Cloud base, c. top, CAPE',ICB,INB,cape
+c sb3d      print *, 'SIG ',(sig(i),i=1,inb)
+c sb3d      print *, 'W ',(w0(i),i=1,inb)
+c sb3d      print *, 'M ',(m(i), i=1,inb)
+c sb3d      print *, 'Dt1 ',(tvp(i)-tv(i),i=1,inb)
+c sb3d      print *, 'Dt_vrai ',(buoy(i),i=1,inb)
+Cjyg2
+C
+C   ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
+C   ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
+C   ***                        FRACTION (SIJ)                          ***
+C
+ 
+ 
+      DO 170 I=ICB,INB
+         RTI=RR(1)-EP(I)*CLW(I)
+         DO 160 J=ICB-1,INB
+            BF2=1.+LV(J)*LV(J)*RS(J)/(RV*T(J)*T(J)*CPD)
+            ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(RTI-RR(J))
+            DENOM=H(I)-HP(I)+(CPD-CPV)*(RR(I)-RTI)*T(J)
+            DEI=DENOM
+            IF(ABS(DEI).LT.0.01)DEI=0.01
+            SIJ(I,J)=ANUM/DEI
+            SIJ(I,I)=1.0
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM/BF2
+            CWAT=CLW(J)*(1.-EP(J))
+            STEMP=SIJ(I,J)
+            IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR.
+     1      ALTEM.GT.CWAT).AND.J.GT.I)THEN
+            ANUM=ANUM-LV(J)*(RTI-RS(J)-CWAT*BF2)
+            DENOM=DENOM+LV(J)*(RR(I)-RTI)
+            IF(ABS(DENOM).LT.0.01)DENOM=0.01
+            SIJ(I,J)=ANUM/DENOM
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM-(BF2-1.)*CWAT
+            END IF
+ 
+ 
+            IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.95)THEN
+               QENT(I,J)=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI
+               UENT(I,J)=SIJ(I,J)*U(I)+(1.-SIJ(I,J))*U(NK)
+               VENT(I,J)=SIJ(I,J)*V(I)+(1.-SIJ(I,J))*V(NK)
+               DO K=1,NTRA
+               TRAENT(I,J,K)=SIJ(I,J)*TRA(I,K)+(1.-SIJ(I,J))*
+     1         TRA(NK,K)
+               END DO
+               ELIJ(I,J)=ALTEM
+               ELIJ(I,J)=AMAX1(0.0,ELIJ(I,J))
+               MENT(I,J)=M(I)/(1.-SIJ(I,J))
+               NENT(I)=NENT(I)+1
+            END IF
+            SIJ(I,J)=AMAX1(0.0,SIJ(I,J))
+            SIJ(I,J)=AMIN1(1.0,SIJ(I,J))
+  160    CONTINUE
+C
+C   ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS  ***
+C   ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES  ***
+C
+         IF(NENT(I).EQ.0)THEN
+            MENT(I,I)=M(I)
+            QENT(I,I)=RR(NK)-EP(I)*CLW(I)
+           UENT(I,I)=U(NK)
+           VENT(I,I)=V(NK)
+           DO J=1,NTRA
+            TRAENT(I,I,J)=TRA(NK,J)
+           END DO
+            ELIJ(I,I)=CLW(I)
+            SIJ(I,I)=1.0
+         END IF
+C
+         DO J = ICB-1,INB
+           SIGIJ(I,J) = SIJ(I,J)
+         ENDDO
+C	
+  170 CONTINUE
+C
+C   ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
+C   ***              PROBABILITIES OF MIXING                     ***
+C
+ 
+      DO 200 I=ICB,INB
+      IF(NENT(I).NE.0)THEN
+       QP=RR(1)-EP(I)*CLW(I)
+       ANUM=H(I)-HP(I)-LV(I)*(QP-RS(I))+(CPV-CPD)*T(I)*
+     1    (QP-RR(I))
+       DENOM=H(I)-HP(I)+LV(I)*(RR(I)-QP)+
+     1    (CPD-CPV)*T(I)*(RR(I)-QP)
+       IF(ABS(DENOM).LT.0.01)DENOM=0.01
+       SCRIT=ANUM/DENOM
+       ALT=QP-RS(I)+SCRIT*(RR(I)-QP)
+       IF(SCRIT.LE.0.0.OR.ALT.LE.0.0)SCRIT=1.0
+       SMAX=0.0
+       ASIJ=0.0
+        DO 175 J=INB,ICB-1,-1
+        IF(SIJ(I,J).GT.1.0E-16.AND.SIJ(I,J).LT.0.95)THEN
+         WGH=1.0
+         IF(J.GT.I)THEN
+          SJMAX=AMAX1(SIJ(I,J+1),SMAX)
+          SJMAX=AMIN1(SJMAX,SCRIT)
+          SMAX=AMAX1(SIJ(I,J),SMAX)
+          SJMIN=AMAX1(SIJ(I,J-1),SMAX)
+          SJMIN=AMIN1(SJMIN,SCRIT)
+          IF(SIJ(I,J).LT.(SMAX-1.0E-16))WGH=0.0
+          SMID=AMIN1(SIJ(I,J),SCRIT)
+         ELSE
+          SJMAX=AMAX1(SIJ(I,J+1),SCRIT)
+          SMID=AMAX1(SIJ(I,J),SCRIT)
+          SJMIN=0.0
+          IF(J.GT.1)SJMIN=SIJ(I,J-1)
+          SJMIN=AMAX1(SJMIN,SCRIT)
+         END IF
+         DELP=ABS(SJMAX-SMID)
+         DELM=ABS(SJMIN-SMID)
+         ASIJ=ASIJ+WGH*(DELP+DELM)
+         MENT(I,J)=MENT(I,J)*(DELP+DELM)*WGH
+        END IF
+  175       CONTINUE
+       ASIJ=AMAX1(1.0E-16,ASIJ)
+       ASIJ=1.0/ASIJ
+       DO 180 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASIJ
+  180    CONTINUE
+       ASUM=0.0
+       BSUM=0.0
+       DO 190 J=ICB-1,INB
+        ASUM=ASUM+MENT(I,J)
+        MENT(I,J)=MENT(I,J)*SIG(J)
+        BSUM=BSUM+MENT(I,J)
+  190       CONTINUE
+       BSUM=AMAX1(BSUM,1.0E-16)
+       BSUM=1.0/BSUM
+       DO 195 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASUM*BSUM	
+  195       CONTINUE
+       CSUM=0.0
+       DO 197 J=ICB-1,INB
+        CSUM=CSUM+MENT(I,J)
+  197       CONTINUE
+ 
+       IF(CSUM.LT.M(I))THEN
+        NENT(I)=0
+        MENT(I,I)=M(I)
+        QENT(I,I)=RR(1)-EP(I)*CLW(I)
+          UENT(I,I)=U(NK)
+          VENT(I,I)=V(NK)
+          DO J=1,NTRA
+           TRAENT(I,I,J)=TRA(NK,J)
+          END DO
+        ELIJ(I,I)=CLW(I)
+        SIJ(I,I)=1.0
+       END IF
+      END IF
+  200      CONTINUE
+ 
+ 
+ 
+***************************************************************
+**       CALCUL DES MENTS(I,J) ET DES QENTS(I,J)
+**************************************************************
+ 
+         DO im=1,nd
+         do jm=1,nd
+ 
+         QENTS(im,jm)=QENT(im,jm)
+         MENTS(im,jm)=MENT(im,jm)
+         enddo
+         enddo
+ 
+***********************************************************
+c--- test sb:
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c@       write(*,*) 'inb,m(inb),ment(inb,inb),sigij(inb,inb):'
+c@       write(*,*) inb,m(inb),ment(inb,inb),sigij(inb,inb)
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c---
+
+ 
+ 
+ 
+C
+C   ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
+C   ***             DOWNDRAFT CALCULATION                      ***
+C
+        IF(EP(INB).LT.0.0001)GOTO 405
+C
+C   ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
+C   ***                AND CONDENSED WATER FLUX                    ***
+C
+        WFLUX=0.0
+        TINV=1./3.
+C
+C    ***                    BEGIN DOWNDRAFT LOOP                    ***
+C
+        DO 400 I=INB,1,-1
+C
+C    ***              CALCULATE DETRAINED PRECIPITATION             ***
+C
+ 
+ 
+        WDTRAIN=10.0*EP(I)*M(I)*CLW(I)
+        IF(I.GT.1)THEN
+         DO 320 J=1,I-1
+       AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+  320    WDTRAIN=WDTRAIN+10.0*AWAT*MENT(J,I)
+        END IF
+C
+C    ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
+C    ***              ESTIMATES OF RP(I)AND RP(I-1)             ***
+C
+ 
+ 
+        WT(I)=45.0
+      IF(I.LT.INB)THEN
+       RP(I)=RP(I+1)+(CPD*(T(I+1)-T(I))+GZ(I+1)-GZ(I))/LV(I)
+       RP(I)=0.5*(RP(I)+RR(I))
+      END IF
+      RP(I)=AMAX1(RP(I),0.0)
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(INB)=RR(INB)
+      IF(I.EQ.1)THEN
+       AFAC=P(1)*(RS(1)-RP(1))/(1.0E4+2000.0*P(1)*RS(1))
+      ELSE
+       RP(I-1)=RP(I)+(CPD*(T(I)-T(I-1))+GZ(I)-GZ(I-1))/LV(I)
+       RP(I-1)=0.5*(RP(I-1)+RR(I-1))
+       RP(I-1)=AMIN1(RP(I-1),RS(I-1))
+       RP(I-1)=AMAX1(RP(I-1),0.0)
+       AFAC1=P(I)*(RS(I)-RP(I))/(1.0E4+2000.0*P(I)*RS(I))
+       AFAC2=P(I-1)*(RS(I-1)-RP(I-1))/(1.0E4+
+     1    2000.0*P(I-1)*RS(I-1))
+       AFAC=0.5*(AFAC1+AFAC2)
+      END IF
+      IF(I.EQ.INB)AFAC=0.0
+        AFAC=AMAX1(AFAC,0.0)
+        BFAC=1./(SIGD*WT(I))
+C
+Cjyg1
+CCC        SIGT=1.0
+CCC        IF(I.GE.ICB)SIGT=SIGP(I)
+C Prise en compte de la variation progressive de SIGT dans
+C les couches ICB et ICB-1:
+C 	Pour PLCL<PH(I+1), PR1=0 & PR2=1
+C 	Pour PLCL>PH(I),   PR1=1 & PR2=0
+C 	Pour PH(I+1)<PLCL<PH(I), PR1 est la proportion a cheval
+C    sur le nuage, et PR2 est la proportion sous la base du
+C    nuage.
+         PR1 =(PLCL-PH(I+1))/(PH(I)-PH(I+1))
+         PR1 = MAX(0.,MIN(1.,PR1))
+         PR2 = (PH(I)-PLCL)/(PH(I)-PH(I+1))
+         PR2 = MAX(0.,MIN(1.,PR2))
+         SIGT = SIGP(I)*PR1 + PR2
+c sb3d         print *,'i,sigt,pr1,pr2', i,sigt,pr1,pr2
+Cjyg2
+C
+        B6=BFAC*50.*SIGD*(PH(I)-PH(I+1))*SIGT*AFAC
+        C6=WATER(I+1)+BFAC*WDTRAIN-50.*SIGD*BFAC*
+     1   (PH(I)-PH(I+1))*EVAP(I+1)
+      IF(C6.GT.0.0)THEN
+         REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
+         EVAP(I)=SIGT*AFAC*REVAP
+         WATER(I)=REVAP*REVAP
+      ELSE
+       EVAP(I)=-EVAP(I+1)+0.02*(WDTRAIN+SIGD*WT(I)*
+     1    WATER(I+1))/(SIGD*(PH(I)-PH(I+1)))
+      END IF
+ 
+ 
+C
+C    ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
+C    ***              HYDROSTATIC APPROXIMATION                 ***
+C
+        IF(I.EQ.1)GOTO 360
+      TEVAP=AMAX1(0.0,EVAP(I))
+      DELTH=AMAX1(0.001,(TH(I)-TH(I-1)))
+      MP(I)=10.*LVCP(I)*SIGD*TEVAP*(P(I-1)-P(I))/DELTH
+C
+C    ***           IF HYDROSTATIC ASSUMPTION FAILS,             ***
+C    ***   SOLVE CUBIC DIFFERENCE EQUATION FOR DOWNDRAFT THETA  ***
+C    ***  AND MASS FLUX FROM TWO SIMULTANEOUS DIFFERENTIAL EQNS ***
+C
+      AMFAC=SIGD*SIGD*70.0*PH(I)*(P(I-1)-P(I))*
+     1   (TH(I)-TH(I-1))/(TV(I)*TH(I))
+      AMP2=ABS(MP(I+1)*MP(I+1)-MP(I)*MP(I))
+      IF(AMP2.GT.(0.1*AMFAC))THEN
+         XF=100.0*SIGD*SIGD*SIGD*(PH(I)-PH(I+1))
+         TF=B(I)-5.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         AF=XF*TF+MP(I+1)*MP(I+1)*TINV
+         BF=2.*(TINV*MP(I+1))**3+TINV*MP(I+1)*XF*TF+50.*
+     1    (P(I-1)-P(I))*XF*TEVAP
+         FAC2=1.0
+         IF(BF.LT.0.0)FAC2=-1.0
+         BF=ABS(BF)
+         UR=0.25*BF*BF-AF*AF*AF*TINV*TINV*TINV
+         IF(UR.GE.0.0)THEN
+          SRU=SQRT(UR)
+          FAC=1.0
+          IF((0.5*BF-SRU).LT.0.0)FAC=-1.0
+          MP(I)=MP(I+1)*TINV+(0.5*BF+SRU)**TINV+
+     1     FAC*(ABS(0.5*BF-SRU))**TINV
+         ELSE
+          D=ATAN(2.*SQRT(-UR)/(BF+1.0E-28))
+          IF(FAC2.LT.0.0)D=3.14159-D
+          MP(I)=MP(I+1)*TINV+2.*SQRT(AF*TINV)*COS(D*TINV)
+         END IF
+         MP(I)=AMAX1(0.0,MP(I))
+         B(I-1)=B(I)+100.0*(P(I-1)-P(I))*TEVAP/(MP(I)+SIGD*0.1)-
+     1    10.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         B(I-1)=AMAX1(B(I-1),0.0)
+      END IF
+ 
+ 
+C
+C   ***         LIMIT MAGNITUDE OF MP(I) TO MEET CFL CONDITION      ***
+C
+      AMPMAX=2.0*(PH(I)-PH(I+1))*DELTI
+      AMP2=2.0*(PH(I-1)-PH(I))*DELTI
+      AMPMAX=AMIN1(AMPMAX,AMP2)
+      MP(I)=AMIN1(MP(I),AMPMAX)
+C
+C    ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
+C    ***       BETWEEN CLOUD BASE AND THE SURFACE                   ***
+C
+          IF(P(I).GT.P(ICB))THEN
+           MP(I)=MP(ICB)*(P(1)-P(I))/(P(1)-P(ICB))
+          END IF
+  360   CONTINUE
+C
+C    ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
+C
+        IF(I.EQ.INB)GOTO 400
+      RP(I)=RR(I)
+        IF(MP(I).GT.MP(I+1))THEN
+        RP(I)=RP(I+1)*MP(I+1)+RR(I)*(MP(I)-MP(I+1))+
+     1       5.*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+EVAP(I))
+        RP(I)=RP(I)/MP(I)
+          UP(I)=UP(I+1)*MP(I+1)+U(I)*(MP(I)-MP(I+1))
+         UP(I)=UP(I)/MP(I)
+          VP(I)=VP(I+1)*MP(I+1)+V(I)*(MP(I)-MP(I+1))
+         VP(I)=VP(I)/MP(I)
+          DO J=1,NTRA
+           TRAP(I,J)=TRAP(I+1,J)*MP(I+1)+
+     s     TRAP(I,J)*(MP(I)-MP(I+1))
+           TRAP(I,J)=TRAP(I,J)/MP(I)
+          END DO
+        ELSE
+        IF(MP(I+1).GT.1.0E-16)THEN
+           RP(I)=RP(I+1)+5.0*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+
+     1      EVAP(I))/MP(I+1)
+            UP(I)=UP(I+1)
+            VP(I)=VP(I+1)
+            DO J=1,NTRA
+             TRAP(I,J)=TRAP(I+1,J)
+            END DO
+        END IF
+        END IF
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(I)=AMAX1(RP(I),0.0)
+  400   CONTINUE
+C
+C   ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
+C
+        PRECIP=WT(1)*SIGD*WATER(1)*8640.0
+
+c sb  ***  Calculate downdraft velocity scale and surface temperature and  ***
+c sb  ***                    water vapor fluctuations                      ***
+c sb		(inspire de convect 4.3)
+
+c       BETAD=10.0         
+       BETAD=5.0         
+       WD=BETAD*ABS(MP(ICB))*0.01*RD*T(ICB)/(SIGD*P(ICB))
+
+  405   CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
+C   ***                      AND MIXING RATIO                        ***
+C
+      DPINV=1.0/(PH(1)-PH(2))
+        AM=0.0
+        DO 410 K=2,INB
+  410   AM=AM+M(K)
+      IF((0.1*DPINV*AM).GE.DELTI)IFLAG=4
+      FT(1)=0.1*DPINV*AM*(T(2)-T(1)+(GZ(2)-GZ(1))/CPN(1))
+        FT(1)=FT(1)-0.5*LVCP(1)*SIGD*(EVAP(1)+EVAP(2))
+        FT(1)=FT(1)-0.09*SIGD*MP(2)*T(1)*B(1)*DPINV
+      FT(1)=FT(1)+0.01*SIGD*WT(1)*(CL-CPD)*WATER(2)*(T(2)-
+     1   T(1))*DPINV/CPN(1)
+        FR(1)=0.1*MP(2)*(RP(2)-RR(1))*
+Ccorrection bug conservation eau
+C    1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+     1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+cIM cf. SBL
+C    1    DPINV+SIGD*EVAP(1)
+        FR(1)=FR(1)+0.1*AM*(RR(2)-RR(1))*DPINV
+        FU(1)=FU(1)+0.1*DPINV*(MP(2)*(UP(2)-U(1))+AM*(U(2)-U(1)))
+        FV(1)=FV(1)+0.1*DPINV*(MP(2)*(VP(2)-V(1))+AM*(V(2)-V(1)))
+        DO J=1,NTRA
+         FTRA(1,J)=FTRA(1,J)+0.1*DPINV*(MP(2)*(TRAP(2,J)-TRA(1,J))+
+     1    AM*(TRA(2,J)-TRA(1,J)))
+        END DO
+        AMDE=0.0
+        DO 415 J=2,INB
+         FR(1)=FR(1)+0.1*DPINV*MENT(J,1)*(QENT(J,1)-RR(1))
+         FU(1)=FU(1)+0.1*DPINV*MENT(J,1)*(UENT(J,1)-U(1))
+         FV(1)=FV(1)+0.1*DPINV*MENT(J,1)*(VENT(J,1)-V(1))
+         DO K=1,NTRA
+          FTRA(1,K)=FTRA(1,K)+0.1*DPINV*MENT(J,1)*(TRAENT(J,1,K)-
+     1     TRA(1,K))
+         END DO
+  415      CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
+C   ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
+C
+C   ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
+C   ***                      THROUGH EACH LEVEL                          ***
+C
+ 
+ 
+        DO 500 I=2,INB
+        DPINV=1.0/(PH(I)-PH(I+1))
+      CPINV=1.0/CPN(I)
+        AMP1=0.0
+        DO 440 K=I+1,INB+1
+  440   AMP1=AMP1+M(K)
+        DO 450 K=1,I
+        DO 450 J=I+1,INB+1
+         AMP1=AMP1+MENT(K,J)
+  450   CONTINUE
+      IF((0.1*DPINV*AMP1).GE.DELTI)IFLAG=4
+        AD=0.0
+        DO 470 K=1,I-1
+        DO 470 J=I,INB
+  470   AD=AD+MENT(J,K)
+      FT(I)=0.1*DPINV*(AMP1*(T(I+1)-T(I)+(GZ(I+1)-GZ(I))*
+     1   CPINV)-AD*(T(I)-T(I-1)+(GZ(I)-GZ(I-1))*CPINV))
+     2   -0.5*SIGD*LVCP(I)*(EVAP(I)+EVAP(I+1))
+      RAT=CPN(I-1)*CPINV
+        FT(I)=FT(I)-0.09*SIGD*(MP(I+1)*T(I)*
+     1    B(I)-MP(I)*T(I-1)*RAT*B(I-1))*DPINV
+      FT(I)=FT(I)+0.1*DPINV*MENT(I,I)*(HP(I)-H(I)+
+     1    T(I)*(CPV-CPD)*(RR(I)-QENT(I,I)))*CPINV
+      FT(I)=FT(I)+0.01*SIGD*WT(I)*(CL-CPD)*WATER(I+1)*
+     1    (T(I+1)-T(I))*DPINV*CPINV
+        FR(I)=0.1*DPINV*(AMP1*(RR(I+1)-RR(I))-
+     1    AD*(RR(I)-RR(I-1)))
+        FU(I)=FU(I)+0.1*DPINV*(AMP1*(U(I+1)-U(I))-
+     1    AD*(U(I)-U(I-1)))
+        FV(I)=FV(I)+0.1*DPINV*(AMP1*(V(I+1)-V(I))-
+     1    AD*(V(I)-V(I-1)))
+        DO K=1,NTRA
+         FTRA(I,K)=FTRA(I,K)+0.1*DPINV*(AMP1*(TRA(I+1,K)-
+     1    TRA(I,K))-AD*(TRA(I,K)-TRA(I-1,K)))
+        END DO
+        DO 480 K=1,I-1
+       AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+         FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-AWAT
+     1    -RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+C (saturated updrafts resulting from mixing)      ! cld   
+         QCOND(I)=QCOND(I)+(ELIJ(K,I)-AWAT)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  480   CONTINUE
+      DO 490 K=I,INB
+       FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  490      CONTINUE
+        FR(I)=FR(I)+0.5*SIGD*(EVAP(I)+EVAP(I+1))+0.1*(MP(I+1)*
+     1    (RP(I+1)-RR(I))-MP(I)*(RP(I)-RR(I-1)))*DPINV
+        FU(I)=FU(I)+0.1*(MP(I+1)*(UP(I+1)-U(I))-MP(I)*
+     1    (UP(I)-U(I-1)))*DPINV
+        FV(I)=FV(I)+0.1*(MP(I+1)*(VP(I+1)-V(I))-MP(I)*
+     1    (VP(I)-V(I-1)))*DPINV
+        DO J=1,NTRA
+         FTRA(I,J)=FTRA(I,J)+0.1*DPINV*(MP(I+1)*(TRAP(I+1,J)-TRA(I,J))-
+     1    MP(I)*(TRAP(I,J)-TRAP(I-1,J)))
+        END DO
+C (saturated downdrafts resulting from mixing)    ! cld
+        DO K=I+1,INB                              ! cld
+         QCOND(I)=QCOND(I)+ELIJ(K,I)              ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDDO                                     ! cld
+C (particular case: no detraining level is found) ! cld
+        IF (NENT(I).EQ.0) THEN                    ! cld
+         QCOND(I)=QCOND(I)+(1-EP(I))*CLW(I)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDIF                                     ! cld
+        IF (NQCOND(I).NE.0.) THEN                 ! cld
+         QCOND(I)=QCOND(I)/NQCOND(I)              ! cld
+        ENDIF                                     ! cld
+  500   CONTINUE
+ 
+ 
+ 
+C
+C   ***   MOVE THE DETRAINMENT AT LEVEL INB DOWN TO LEVEL INB-1   ***
+C   ***        IN SUCH A WAY AS TO PRESERVE THE VERTICALLY        ***
+C   ***          INTEGRATED ENTHALPY AND WATER TENDENCIES         ***
+C
+c test sb:
+c@      write(*,*) '--------------------------------------------'
+c@      write(*,*) 'inb,ft,hp,h,t,rr,qent,ment,water,waterp,wt,mp,b'
+c@      write(*,*) inb,ft(inb),hp(inb),h(inb)
+c@     :   ,t(inb),rr(inb),qent(inb,inb)
+c@     :   ,ment(inb,inb),water(inb)
+c@     :   ,water(inb+1),wt(inb),mp(inb),b(inb)
+c@      write(*,*) '--------------------------------------------'
+c fin test sb:
+
+      AX=0.1*MENT(INB,INB)*(HP(INB)-H(INB)+T(INB)*
+     1    (CPV-CPD)*(RR(INB)-QENT(INB,INB)))/(CPN(INB)*
+     2    (PH(INB)-PH(INB+1)))
+      FT(INB)=FT(INB)-AX
+      FT(INB-1)=FT(INB-1)+AX*CPN(INB)*(PH(INB)-PH(INB+1))/
+     1    (CPN(INB-1)*(PH(INB-1)-PH(INB)))
+      BX=0.1*MENT(INB,INB)*(QENT(INB,INB)-RR(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FR(INB)=FR(INB)-BX
+      FR(INB-1)=FR(INB-1)+BX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      CX=0.1*MENT(INB,INB)*(UENT(INB,INB)-U(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FU(INB)=FU(INB)-CX
+      FU(INB-1)=FU(INB-1)+CX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DX=0.1*MENT(INB,INB)*(VENT(INB,INB)-V(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FV(INB)=FV(INB)-DX
+      FV(INB-1)=FV(INB-1)+DX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DO J=1,NTRA
+      EX=0.1*MENT(INB,INB)*(TRAENT(INB,INB,J)
+     1    -TRA(INB,J))/(PH(INB)-PH(INB+1))
+      FTRA(INB,J)=FTRA(INB,J)-EX
+      FTRA(INB-1,J)=FTRA(INB-1,J)+EX*
+     1     (PH(INB)-PH(INB+1))/(PH(INB-1)-PH(INB))
+      ENDDO   
+C
+C   ***    HOMOGINIZE TENDENCIES BELOW CLOUD BASE    ***
+C
+      ASUM=0.0
+      BSUM=0.0
+      CSUM=0.0
+        DSUM=0.0
+      DO 650 I=1,ICB-1
+       ASUM=ASUM+FT(I)*(PH(I)-PH(I+1))
+         BSUM=BSUM+FR(I)*(LV(I)+(CL-CPD)*(T(I)-T(1)))*
+     1    (PH(I)-PH(I+1))
+       CSUM=CSUM+(LV(I)+(CL-CPD)*(T(I)-T(1)))*(PH(I)-PH(I+1))
+       DSUM=DSUM+T(I)*(PH(I)-PH(I+1))/TH(I)
+  650      CONTINUE
+      DO 700 I=1,ICB-1
+       FT(I)=ASUM*T(I)/(TH(I)*DSUM)
+       FR(I)=BSUM/CSUM
+  700      CONTINUE
+C
+C   ***           RESET COUNTER AND RETURN           ***
+C
+      SIG(ND)=2.0
+c
+c
+      do i = 1, nd
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+c sb       dnwd0(i) = - mp(i)
+      enddo
+c
+      do i = 1, nl
+       dnwd0(i) = - mp(i)
+      enddo
+      do i = nl+1, nd
+       dnwd0(i) = 0.
+      enddo
+c
+      do i = icb, inb
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+
+         do k =i, inb
+            up1=0.0
+            dn1=0.0
+            do n = 1, i-1
+               up1 = up1 + ment(n,k)
+               dn1 = dn1 - ment(k,n)
+            enddo
+            upwd(i) = upwd(i)+ m(k) + up1
+            dnwd(i) = dnwd(i) + dn1
+         enddo
+        enddo
+ 
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        DETERMINATION DE LA VARIATION DE FLUX ASCENDANT ENTRE
+C        DEUX NIVEAU NON DILUE Mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+c sb      do i=1,ND
+c sb      Mike(i)=M(i)
+c sb      enddo
+ 
+      do i = 1, NL
+       Mike(i) = M(i)
+      enddo
+      do i = NL+1, ND
+       Mike(i) = 0.
+      enddo
+ 
+      do i=1,nd
+      Ma(i)=0
+      enddo
+ 
+c sb      do i=1,nd
+c sb      do j=i,nd
+c sb      Ma(i)=Ma(i)+M(j)
+c sb      enddo
+c sb      enddo
+
+      do i = 1, NL
+      do j = i, NL
+       Ma(i) = Ma(i) + M(j)
+      enddo
+      enddo
+c
+      do i = NL+1, ND
+       Ma(i) = 0.
+      enddo
+c 
+      do i=1,ICB-1
+      Ma(i)=0
+      enddo
+ 
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C        ICB REPRESENTE DE NIVEAU OU SE TROUVE LA
+c        BASE DU NUAGE , ET INB LE TOP DU NUAGE
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+       do i=1,ND
+       Mke(i)=upwd(i)+dnwd(i)
+       enddo
+
+C
+C   *** Diagnose the in-cloud mixing ratio   ***              ! cld
+C   ***           of condensed water         ***              ! cld
+C                                                             ! cld
+       DO I=1,ND                                              ! cld
+        MAA(I)=0.0                                            ! cld
+        WA(I)=0.0                                             ! cld
+        SIGA(I)=0.0                                           ! cld
+       ENDDO                                                  ! cld
+       DO I=NK,INB                                            ! cld
+       DO K=I+1,INB+1                                         ! cld
+        MAA(I)=MAA(I)+M(K)                                    ! cld
+       ENDDO                                                  ! cld
+       ENDDO                                                  ! cld
+       DO I=ICB,INB-1                                         ! cld
+        AXC(I)=0.                                             ! cld
+        DO J=ICB,I                                            ! cld
+         AXC(I)=AXC(I)+RD*(TVP(J)-TV(J))*(PH(J)-PH(J+1))/P(J) ! cld
+        ENDDO                                                 ! cld
+        IF (AXC(I).GT.0.0) THEN                               ! cld
+         WA(I)=SQRT(2.*AXC(I))                                ! cld
+        ENDIF                                                 ! cld
+       ENDDO                                                  ! cld
+       DO I=1,NL                                              ! cld
+        IF (WA(I).GT.0.0)                                     ! cld
+     1    SIGA(I)=MAA(I)/WA(I)*RD*TVP(I)/P(I)/100./DELTAC     ! cld
+        SIGA(I) = MIN(SIGA(I),1.0)                            ! cld
+        QCONDC(I)=SIGA(I)*CLW(I)*(1.-EP(I))                   ! cld
+     1          + (1.-SIGA(I))*QCOND(I)                       ! cld
+       ENDDO                                                  ! cld
+
+
+c@$$cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c@$$         call writeg1d(1,klev,ma,'ma  ','ma  ')
+c@$$          call writeg1d(1,klev,upwd,'upwd  ','upwd  ')
+c@$$          call writeg1d(1,klev,dnwd,'dnwd  ','dnwd  ')
+c@$$          call writeg1d(1,klev,dnwd0,'dnwd0  ','dnwd0  ')
+c@$$          call writeg1d(1,klev,tvp,'tvp  ','tvp  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,3),'tra3  ','tra3  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,4),'tra4  ','tra4  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,5),'tra5  ','tra5  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,6),'tra6  ','tra6  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,7),'tra7  ','tra7  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,8),'tra8  ','tra8  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,9),'tra9  ','tra9  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,10),'tra10','tra10')
+c@$$          call writeg1d(1,klev,tra(1:klev,11),'tra11','tra11')
+c@$$          call writeg1d(1,klev,tra(1:klev,12),'tra12','tra12')
+c@$$          call writeg1d(1,klev,tra(1:klev,13),'tra13','tra13')
+c@$$          call writeg1d(1,klev,tra(1:klev,14),'tra14','tra14')
+c@$$          call writeg1d(1,klev,tra(1:klev,15),'tra15','tra15')
+c@$$          call writeg1d(1,klev,tra(1:klev,16),'tra16','tra16')
+c@$$          call writeg1d(1,klev,tra(1:klev,17),'tra17','tra17')
+c@$$          call writeg1d(1,klev,tra(1:klev,18),'tra18','tra18')
+c@$$          call writeg1d(1,klev,tra(1:klev,19),'tra19','tra19')
+c@$$          call writeg1d(1,klev,tra(1:klev,20),'tra20','tra20 ')
+c@$$          call writeg1d(1,klev,trap(1:klev,1),'trp1','trp1')
+c@$$          call writeg1d(1,klev,trap(1:klev,2),'trp2','trp2')
+c@$$          call writeg1d(1,klev,trap(1:klev,3),'trp3','trp3')
+c@$$          call writeg1d(1,klev,trap(1:klev,4),'trp4','trp4')
+c@$$          call writeg1d(1,klev,trap(1:klev,5),'trp5','trp5')
+c@$$          call writeg1d(1,klev,trap(1:klev,10),'trp10','trp10')
+c@$$          call writeg1d(1,klev,trap(1:klev,12),'trp12','trp12')
+c@$$          call writeg1d(1,klev,trap(1:klev,15),'trp15','trp15')
+c@$$          call writeg1d(1,klev,trap(1:klev,20),'trp20','trp20')
+c@$$          call writeg1d(1,klev,ftra(1:klev,1),'ftr1  ','ftr1  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,2),'ftr2  ','ftr2  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,3),'ftr3  ','ftr3  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,4),'ftr4  ','ftr4  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,5),'ftr5  ','ftr5  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,6),'ftr6  ','ftr6  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,7),'ftr7  ','ftr7  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,8),'ftr8  ','ftr8  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,9),'ftr9  ','ftr9  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,10),'ftr10','ftr10')
+c@$$          call writeg1d(1,klev,ftra(1:klev,11),'ftr11','ftr11')
+c@$$          call writeg1d(1,klev,ftra(1:klev,12),'ftr12','ftr12')
+c@$$          call writeg1d(1,klev,ftra(1:klev,13),'ftr13','ftr13')
+c@$$          call writeg1d(1,klev,ftra(1:klev,14),'ftr14','ftr14')
+c@$$          call writeg1d(1,klev,ftra(1:klev,15),'ftr15','ftr15')
+c@$$          call writeg1d(1,klev,ftra(1:klev,16),'ftr16','ftr16')
+c@$$          call writeg1d(1,klev,ftra(1:klev,17),'ftr17','ftr17')
+c@$$          call writeg1d(1,klev,ftra(1:klev,18),'ftr18','ftr18')
+c@$$          call writeg1d(1,klev,ftra(1:klev,19),'ftr19','ftr19')
+c@$$          call writeg1d(1,klev,ftra(1:klev,20),'ftr20','ftr20 ')
+c@$$          call writeg1d(1,klev,mp,'mp  ','mp ')
+c@$$          call writeg1d(1,klev,Mke,'Mke  ','Mke ')
+
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c
+        RETURN
+        END
+C ---------------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cpl_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cpl_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cpl_mod.F90	(revision 984)
@@ -0,0 +1,1223 @@
+!
+! $Header$
+!
+MODULE cpl_mod
+!
+! This module excahanges and transforms all fields that should be recieved or sent to 
+! coupler. The transformation of the fields are done from the grid 1D-array in phylmd 
+! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each 
+! timestep is done in here. 
+!
+! Each type of surface that recevie fields from the coupler have a subroutine named 
+! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler 
+! have a subroutine named cpl_send_XXX_fields.
+!
+!*************************************************************************************
+
+! Use statements
+!*************************************************************************************
+  USE dimphy, ONLY : klon
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  USE iophy
+
+! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters 
+! in the module are compiled and not the subroutines.
+  USE oasis
+  USE write_field_phy
+  
+! Global attributes
+!*************************************************************************************
+  IMPLICIT NONE
+  PRIVATE
+
+  ! All subroutine are public except cpl_send_all and cpl_receive_all
+  PUBLIC :: cpl_init, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
+       cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
+       cpl_send_landice_fields, gath2cpl
+  
+
+! Declaration of module variables
+!*************************************************************************************
+! variable for coupling period
+  INTEGER, SAVE                             :: nexca
+  !$OMP THREADPRIVATE(nexca)
+
+! variables for cumulating fields during a coupling periode :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_sols, cpl_nsol, cpl_rain
+  !$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_snow, cpl_evap, cpl_tsol
+  !$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_fder, cpl_albe, cpl_taux
+  !$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp
+  !$OMP THREADPRIVATE(cpl_windsp)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_tauy
+  !$OMP THREADPRIVATE(cpl_tauy)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
+  !$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
+
+! variables read from coupler :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sst     ! sea surface temperature
+  !$OMP THREADPRIVATE(read_sst)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sit     ! sea ice temperature
+  !$OMP THREADPRIVATE(read_sit)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sic     ! sea ice fraction
+  !$OMP THREADPRIVATE(read_sic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_alb_sic ! albedo at sea ice
+  !$OMP THREADPRIVATE(read_alb_sic)
+  
+! fraction for different surface, saved during whole coupling period
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: pctsrf_sav   
+  !$OMP THREADPRIVATE(pctsrf_sav)
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: unity
+  !$OMP THREADPRIVATE(unity)
+  INTEGER, SAVE                             :: nidct, nidcs
+  !$OMP THREADPRIVATE(nidct,nidcs)
+
+! variables to be sent to the coupler
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
+  !$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
+  !$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
+  !$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
+  !$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp2D
+  !$OMP THREADPRIVATE(cpl_windsp2D)
+  
+
+CONTAINS
+!
+!************************************************************************************
+!
+  SUBROUTINE cpl_init(dtime, rlon, rlat)
+
+    INCLUDE "dimensions.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "control.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER                           :: error, sum_error, ig, i
+    INTEGER                           :: jf, nhoridct
+    INTEGER                           :: nhoridcs
+    INTEGER                           :: idtime
+    INTEGER                           :: idayref
+    INTEGER                           :: npas ! only for OASIS2
+    REAL                              :: zjulian
+    REAL, DIMENSION(iim,jjm+1)        :: zx_lon, zx_lat
+    CHARACTER(len = 20)               :: modname = 'cpl_init'
+    CHARACTER(len = 80)               :: abort_message
+    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
+
+!*************************************************************************************
+! Calculate coupling period
+!
+!*************************************************************************************
+     
+    npas = itaufin/ iphysiq
+    nexca = 86400 / dtime
+    WRITE(lunout,*)' ##### Ocean couple #####'
+    WRITE(lunout,*)' Valeurs des pas de temps'
+    WRITE(lunout,*)' npas = ', npas
+    WRITE(lunout,*)' nexca = ', nexca
+    
+!*************************************************************************************
+! Allocate variables
+!
+!*************************************************************************************
+    error = 0
+    sum_error = 0
+
+    ALLOCATE(unity(klon), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(pctsrf_sav(klon,nbsrf), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_sols(klon,2), stat = error) 
+    sum_error = sum_error + error
+    ALLOCATE(cpl_nsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rain(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_snow(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_evap(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_fder(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_albe(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_taux(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_windsp(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tauy(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sst(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sit(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+
+    IF (sum_error /= 0) THEN
+       abort_message='Pb allocation variables couplees'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+!*************************************************************************************
+! Initialize the allocated varaibles
+!
+!*************************************************************************************
+    DO ig = 1, klon
+       unity(ig) = ig
+    ENDDO
+    pctsrf_sav = 0.
+
+    cpl_sols = 0.   ; cpl_nsol = 0.  ; cpl_rain = 0.   ; cpl_snow = 0.
+    cpl_evap = 0.   ; cpl_tsol = 0.  ; cpl_fder = 0.   ; cpl_albe = 0.
+    cpl_taux = 0.   ; cpl_tauy = 0.  ; cpl_rriv2D = 0. ; cpl_rcoa2D = 0.
+    cpl_rlic2D = 0. ; cpl_windsp = 0.
+
+!*************************************************************************************
+! Initialize coupling
+!
+!*************************************************************************************
+    idtime = INT(dtime)
+#ifdef CPP_COUPLE
+    CALL inicma
+#endif
+
+!*************************************************************************************
+! initialize NetCDF output
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       idayref = day_ini
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+       DO i = 1, iim
+          zx_lon(i,1) = rlon(i+1)
+          zx_lon(i,jjm+1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+       clintocplnam="cpl_atm_tauflx"
+       CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
+            1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct) 
+! no vertical axis
+       CALL histdef(nidct, 'tauxe','tauxe', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tauyn','tauyn', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lon','tmp_lon', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lat','tmp_lat', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       DO jf=1,jpflda2o1 + jpflda2o2
+          CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
+               "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidct)
+       CALL histsync(nidct)
+       
+       clfromcplnam="cpl_atm_sst"
+       CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
+            0,zjulian,dtime,nhoridcs,nidcs) 
+! no vertical axis
+       DO jf=1,jpfldo2a
+          CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
+               "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidcs)
+       CALL histsync(nidcs)
+
+    ENDIF    ! is_sequential
+    
+  END SUBROUTINE cpl_init
+  
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_receive_all(itime, dtime, pctsrf)
+! This subroutine reads from coupler for both ocean and seaice
+! 4 fields : read_sst, read_sic, read_sit and read_alb_sic. 
+
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Local variables
+!************************************************************************************
+    INTEGER                                 :: j, ig, il_time_secs
+    INTEGER                                 :: itau_w
+    INTEGER, DIMENSION(iim*(jjm+1))         :: ndexcs
+    CHARACTER(len = 20)                     :: modname = 'cpl_receive_all'
+    CHARACTER(len = 80)                     :: abort_message
+    REAL, DIMENSION(klon)                   :: read_sic1D
+    REAL, DIMENSION(iim,jj_nb,jpfldo2a)  :: tab_read_flds
+    REAL, DIMENSION(iim,jj_nb)           :: read_sic
+
+!*************************************************************************************
+! Start calculation
+! Get fields from coupler
+!
+!*************************************************************************************
+
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL fromcpl(il_time_secs, tab_read_flds)
+#endif
+    
+! NetCDF output of received fields
+    IF (is_sequential) THEN
+       ndexcs(:) = 0
+       itau_w = itau_phy + itime
+       DO ig = 1, jpfldo2a
+          CALL histwrite(nidcs,cl_read(ig),itau_w,tab_read_flds(:,:,ig),iim*(jjm+1),ndexcs)
+       END DO
+    ENDIF
+
+! Save each field in a 2D array. 
+    read_sst(:,:)     = tab_read_flds(:,:,1)  ! Sea surface temperature
+    read_sic(:,:)     = tab_read_flds(:,:,2)  ! Sea ice concentration
+    read_alb_sic(:,:) = tab_read_flds(:,:,3)  ! Albedo at sea ice
+    read_sit(:,:)     = tab_read_flds(:,:,4)  ! Sea ice temperature
+
+!*************************************************************************************
+! Temperature and albedo are weighted with the fraction of sea-ice(read-sic)
+!
+!*************************************************************************************
+    DO j = 1, jj_nb
+       DO ig = 1, iim
+          IF (ABS(1. - read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = RTT - 1.8
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ELSE IF (ABS(read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sst(ig,j)
+             read_alb_sic(ig,j) =  0.6
+          ELSE
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ENDIF
+       ENDDO
+    ENDDO
+    
+!*************************************************************************************
+!  Transform seaice fraction, read_sic into pctsrf_sav
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sic, read_sic1D, klon, unity)
+
+    DO ig = 1, klon
+       ! treatment only of ocean and/or seaice points
+       IF (pctsrf(ig,is_oce) > epsfra .OR. &
+            pctsrf(ig,is_sic) > epsfra) THEN
+          pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               * read_sic1D(ig)
+          pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               - pctsrf_sav(ig,is_sic)
+       ENDIF
+    ENDDO
+
+!*************************************************************************************
+! To avoid round up problems
+!
+!*************************************************************************************
+    WHERE (ABS(pctsrf_sav(:,is_sic)) .LE. 2.*EPSILON(pctsrf_sav(1,is_sic)))
+       pctsrf_sav(:,is_sic) = 0.
+       pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+    ENDWHERE
+    WHERE (ABS(pctsrf_sav(:,is_oce)) .LE. 2.*EPSILON(pctsrf_sav(1,is_oce)))
+       pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+       pctsrf_sav(:,is_oce) = 0.
+    ENDWHERE
+    IF (MINVAL(pctsrf_sav(:,is_oce)) < 0.) THEN
+       WRITE(*,*)'Pb fraction ocean inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_oce))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_oce)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    IF (MINVAL(pctsrf_sav(:,is_sic)) < 0.) THEN
+       WRITE(*,*)'Pb fraction glace inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_sic))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_sic)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+        
+  END SUBROUTINE cpl_receive_all
+!
+!*************************************************************************************
+! 
+  SUBROUTINE cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf, &
+       tsurf_new, pctsrf_oce)
+!
+! This routine reads, if first time step in a coupling period, all fields reveived from
+! coupler for all types of surfaces. It returns the fields for the ocean surface which
+! are the sea surface temperature and the fraction of ocean. 
+! The fields are transformed into 1D arrays with valid points : 
+! tsurf_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_oce
+
+!*************************************************************************************
+! If first time step in a coupling period receive all fields for all types
+! of surfaces from coupler : read_sst, read_sit, read_alb_sic and pctsrf_sav. 
+! 
+!*************************************************************************************
+
+    IF (MOD(itime, nexca) == 1) CALL cpl_receive_all(itime, dtime, pctsrf)
+
+
+!*************************************************************************************
+! Transform read_sst into compressed 1D variable tsurf_new
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sst, tsurf_new, knon, knindex)
+    pctsrf_oce(:) = pctsrf_sav(:,is_oce) 
+
+
+  END SUBROUTINE cpl_receive_ocean_fields
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl_receive_seaice_fields(knon, knindex, &
+       tsurf_new, alb_new, pctsrf_sic)
+!
+! This routine returns the fields for the seaice that have been read from the coupler
+! (done earlier with cpl_receive_ocean_fields). These fields are the temperature and 
+! albedo at sea ice surface and fraction of sea ice.
+! The fields are transformed into  1D arrays with valid points : 
+! tsurf_new(1:knon), alb_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_sic
+
+
+!*************************************************************************************
+! Transform fields read from coupler from 2D into compressed 1D variables
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sit, tsurf_new, knon, knindex)
+    CALL cpl2gath(read_alb_sic, alb_new, knon, knindex)
+    pctsrf_sic(:) = pctsrf_sav(:,is_sic) 
+
+  END SUBROUTINE cpl_receive_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder, albsol
+    REAL, DIMENSION(klon), INTENT(IN)       :: taux, tauy, windsp
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_ocean_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+!*************************************************************************************
+! Start calculation
+! The ocean points are saved with second array index=1
+!
+!*************************************************************************************
+    cpl_index = 1
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+       cpl_windsp(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+       cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
+            windsp(ig)      / FLOAT(nexca) 
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid. 
+! No sending to the coupler (it is done from cpl_send_seaice_fields).
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)!
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_windsp(1,cpl_index), cpl_windsp2D(1,1), &
+            knon, knindex)
+
+    ENDIF
+
+  END SUBROUTINE cpl_send_ocean_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. All fields for all types of surfaces are sent to
+! the coupler.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder
+    REAL, DIMENSION(klon), INTENT(IN)       :: albsol, taux, tauy
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+    LOGICAL, INTENT(IN)                     :: lafin
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_seaice_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+
+!*************************************************************************************
+! Start calulation
+! The sea-ice points are saved with second array index=2
+!
+!*************************************************************************************
+    cpl_index = 2
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid and all fields are sent to coupler.
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       ! Send all fields
+       CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+    ENDIF
+
+  END SUBROUTINE cpl_send_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rriv_in
+    REAL, DIMENSION(klon), INTENT(IN)         :: rcoa_in
+
+! Local variables
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rriv2D
+    REAL, DIMENSION(iim,jj_nb)             :: rcoa2D
+
+!*************************************************************************************
+! Rearrange fields in 2D variables 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rriv2D(:,:) = 0.0
+    rcoa2D(:,:) = 0.0
+    CALL gath2cpl(rriv_in, rriv2D, knon, knindex)
+    CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex)
+
+!*************************************************************************************
+! Reset cumulated fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rriv2D(:,:) = 0.0
+       cpl_rcoa2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Following fields should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca)
+    cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_land_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in)
+! This subroutine cumulates the field for melting ice for each time-step 
+! during a coupling period. This routine will not send to coupler. Sending 
+! will be done in cpl_send_seaice_fields.
+!
+    INCLUDE "dimensions.h"
+    
+! Input varibales
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlic_in
+
+! Local varibales
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rlic2D
+
+!*************************************************************************************
+! Rearrange field in a 2D variable 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rlic2D(:,:) = 0.0
+    CALL gath2cpl(rlic_in, rlic2D, knon, knindex)
+
+!*************************************************************************************
+! Reset field to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rlic2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Melting ice should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_landice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+! This routine will send fields for all different surfaces to the coupler.
+! This subroutine should be executed after calculations by the last surface(sea-ice),
+! all calculations at the different surfaces have to be done before. 
+!    
+! Some includes
+!*************************************************************************************
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                                  :: itime
+    REAL, INTENT(IN)                                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)                    :: rlon, rlat
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)              :: pctsrf
+    LOGICAL, INTENT(IN)                                  :: lafin
+    
+! Local variables
+!*************************************************************************************
+    INTEGER                                              :: error, sum_error, j
+    INTEGER                                              :: itau_w
+    INTEGER                                              :: il_time_secs
+    INTEGER, DIMENSION(iim*(jjm+1))                      :: ndexct
+    REAL                                                 :: Up, Down
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_lon, tmp_lat
+    REAL, DIMENSION(iim, jj_nb, 4)                       :: pctsrf2D
+    REAL, DIMENSION(iim, jj_nb)                          :: deno
+    CHARACTER(len = 20)                                  :: modname = 'cpl_send_all'
+    CHARACTER(len = 80)                                  :: abort_message
+   
+! Variables with fields to coupler
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_taux
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_tauy
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_calv
+! Table with all fields to send to coupler
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2)     :: tab_flds
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
+#endif
+
+! End definitions
+!*************************************************************************************
+    
+
+
+!*************************************************************************************
+! All fields are stored in a table tab_flds(:,:,:)
+! First store the fields 7 to 18 which are already on the right format
+!
+!*************************************************************************************
+    tab_flds(:,:,7)  = cpl_windsp2D(:,:)
+    tab_flds(:,:,8)  = cpl_sols2D(:,:,2)
+    tab_flds(:,:,9)  = cpl_sols2D(:,:,1)
+    tab_flds(:,:,10) = cpl_nsol2D(:,:,2)
+    tab_flds(:,:,11) = cpl_nsol2D(:,:,1)
+    tab_flds(:,:,12) = cpl_fder2D(:,:,2)
+    tab_flds(:,:,13) = cpl_evap2D(:,:,2)
+    tab_flds(:,:,14) = cpl_evap2D(:,:,1)
+    tab_flds(:,:,17) = cpl_rcoa2D(:,:)
+    tab_flds(:,:,18) = cpl_rriv2D(:,:)
+    
+!*************************************************************************************
+! Transform the fraction of sub-surfaces from 1D to 2D array
+!
+!*************************************************************************************
+    pctsrf2D(:,:,:) = 0.
+    CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
+
+!*************************************************************************************
+! Calculate the average calving per latitude
+! Store calving in tab_flds(:,:,19)
+! 
+!*************************************************************************************      
+    DO j = 1, jj_nb
+       tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
+            pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
+    ENDDO
+    
+    
+    IF (is_parallel) THEN
+       IF (.NOT. is_north_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
+          CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_south_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
+          CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
+          Up=Up+tmp_calv(iim,1)
+          tmp_calv(:,1)=Up
+       ENDIF
+       
+       IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
+          Down=Down+tmp_calv(1,jj_nb)
+          tmp_calv(:,jj_nb)=Down	 
+       ENDIF
+    ENDIF
+      
+
+    tab_flds(:,:,19) = tmp_calv(:,:)
+
+!*************************************************************************************
+! Calculate total flux for snow, rain and wind with weighted addition using the 
+! fractions of ocean and seaice.
+!
+! Store the fields for rain and snow directly in tab_flds(:,:,15) and 
+! tab_flds(:,:,16) respectively.
+!
+!*************************************************************************************    
+    tab_flds(:,:,15) = 0.0
+    tab_flds(:,:,16) = 0.0
+    tmp_taux(:,:)    = 0.0
+    tmp_tauy(:,:)    = 0.0
+    
+
+    ! fraction oce+seaice
+    deno =  pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) 
+    ! For all valid grid cells containing some fraction of ocean or sea-ice
+    WHERE ( deno(:,:) /= 0 )
+       tab_flds(:,:,15) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       tab_flds(:,:,16) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       
+       tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+    ENDWHERE
+
+!*************************************************************************************
+! Transform the wind components from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates. 
+! Store the resulting wind components in tab_flds(:,:,1:6)
+!*************************************************************************************
+
+! Transform the longitudes and latitudes on 2D arrays
+    CALL Grid1DTo2D_mpi(rlon,tmp_lon)
+    CALL Grid1DTo2D_mpi(rlat,tmp_lat)
+    
+    IF (is_sequential) THEN
+       IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
+       IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
+    ENDIF
+      
+! NetCDF output of the wind before transformation of coordinate system
+    IF (is_sequential) THEN
+       ndexct(:) = 0
+       itau_w = itau_phy + itime
+       CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
+    ENDIF
+
+! Transform the wind from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates 
+    CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
+         tab_flds(:,:,1), tab_flds(:,:,2), tab_flds(:,:,3) )
+    
+    tab_flds(:,:,4)  = tab_flds(:,:,1)
+    tab_flds(:,:,5)  = tab_flds(:,:,2)
+    tab_flds(:,:,6)  = tab_flds(:,:,3)
+
+!*************************************************************************************
+! NetCDF output of all fields just before sending to coupler.
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       CALL histwrite(nidct,cl_writ(8), itau_w,tab_flds(:,:,8), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(9), itau_w,tab_flds(:,:,9), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(10),itau_w,tab_flds(:,:,10),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(11),itau_w,tab_flds(:,:,11),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(12),itau_w,tab_flds(:,:,12),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(13),itau_w,tab_flds(:,:,13),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(14),itau_w,tab_flds(:,:,14),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(15),itau_w,tab_flds(:,:,15),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(16),itau_w,tab_flds(:,:,16),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(17),itau_w,tab_flds(:,:,17),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(18),itau_w,tab_flds(:,:,18),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(19),itau_w,tab_flds(:,:,19),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(1), itau_w,tab_flds(:,:,1), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(2), itau_w,tab_flds(:,:,2), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(3), itau_w,tab_flds(:,:,3), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(4), itau_w,tab_flds(:,:,4), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(5), itau_w,tab_flds(:,:,5), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(6), itau_w,tab_flds(:,:,6), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(7), itau_w,tab_flds(:,:,7), iim*(jjm+1),ndexct)
+       CALL histsync(nidct)
+    ENDIF
+
+
+!*************************************************************************************
+! Send the table of all fields
+!
+!*************************************************************************************
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
+#endif
+
+!*************************************************************************************
+! Finish with some dellocate
+!
+!*************************************************************************************  
+    sum_error=0
+    DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, stat=error )
+    sum_error = sum_error + error
+    IF (sum_error /= 0) THEN
+       abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+  END SUBROUTINE cpl_send_all
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! 
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+
+! Input
+    INTEGER, INTENT(IN)                       :: knon
+    REAL, DIMENSION(iim,jj_nb), INTENT(IN)    :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+
+! Output
+    REAL, DIMENSION(klon), INTENT(OUT)        :: champ_out
+
+! Local
+    INTEGER                                   :: i, ig
+    REAL, DIMENSION(klon)                     :: tamp
+
+!*************************************************************************************
+!
+! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
+    CALL Grid2Dto1D_mpi(champ_in,tamp)
+
+! Compress from klon to knon
+    DO i = 1, knon
+       ig = knindex(i)
+       champ_out(i) = tamp(ig)
+    ENDDO
+
+  END SUBROUTINE cpl2gath
+!
+!*************************************************************************************
+!
+  SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                    :: knon
+    REAL, DIMENSION(klon), INTENT(IN)      :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)   :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                :: i, ig
+    REAL, DIMENSION(klon)                  :: tamp
+
+!*************************************************************************************
+
+! Decompress from knon to klon
+    tamp = 0.
+    DO i = 1, knon
+       ig = knindex(i)
+       tamp(ig) = champ_in(i)
+    ENDDO
+
+! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
+    CALL Grid1Dto2D_mpi(tamp,champ_out)
+    
+    IF (is_north_pole) champ_out(:,1)=tamp(1)
+    IF (is_south_pole) champ_out(:,jj_nb)=tamp(klon)
+    
+  END SUBROUTINE gath2cpl
+!
+!*************************************************************************************
+!
+END MODULE cpl_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv30_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv30_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv30_routines.F	(revision 984)
@@ -0,0 +1,3145 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE cv30_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+C   ***                        OF CLOUD                         ***
+C
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+C
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cv30param.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+c -- "microphysical" parameters:
+
+      sigd   = 0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+cIM cf. FH     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+      dttrig = 5.   ! (loose) condition for triggering 
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau    = 8000.
+      beta   = 1.0 - delt/tau
+      alpha  = 1.5E-3 * delt/tau
+c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end
+
+      SUBROUTINE cv30_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+
+c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv30_feed(len,nd,t,q,qs,p,ph,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cv30param.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+      real A, B ! convect3
+cym
+      plcl=0.0
+c@ !-------------------------------------------------------------------
+c@ ! --- Find level of minimum moist static energy
+c@ ! --- If level of minimum moist static energy coincides with
+c@ ! --- or is lower than minimum allowable parcel origin level,
+c@ ! --- set iflag to 6.
+c@ !-------------------------------------------------------------------
+c@ 
+c@       do 180 i=1,len
+c@        work(i)=1.0e12
+c@        ihmin(i)=nl
+c@  180  continue
+c@       do 200 k=2,nlp
+c@         do 190 i=1,len
+c@          if((hm(i,k).lt.work(i)).and.
+c@      &      (hm(i,k).lt.hm(i,k-1)))then
+c@            work(i)=hm(i,k)
+c@            ihmin(i)=k
+c@          endif
+c@  190    continue
+c@  200  continue
+c@       do 210 i=1,len
+c@         ihmin(i)=min(ihmin(i),nlm)
+c@         if(ihmin(i).le.minorig)then
+c@           iflag(i)=6
+c@         endif
+c@  210  continue
+c@ c
+c@ !-------------------------------------------------------------------
+c@ ! --- Find that model level below the level of minimum moist static
+c@ ! --- energy that has the maximum value of moist static energy
+c@ !-------------------------------------------------------------------
+c@  
+c@       do 220 i=1,len
+c@        work(i)=hm(i,minorig)
+c@        nk(i)=minorig
+c@  220  continue
+c@       do 240 k=minorig+1,nl
+c@         do 230 i=1,len
+c@          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+c@            work(i)=hm(i,k)
+c@            nk(i)=k
+c@          endif
+c@  230     continue
+c@  240  continue
+
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+  220    continue
+
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( t(i,nk(i)).lt.250.0    )
+     &       .or.( q(i,nk(i)).le.0.0      )     )
+c@      &       .or.( p(i,ihmin(i)).lt.400.0 )  )
+     &   .and.
+     &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+c ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+c ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 
+        endif ! iflag=7  
+
+ 260   continue
+
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv30_undilute1(len,nd,t,q,qs,gz,plcl,p,nk,icb
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len)
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd) 
+      real plcl(len) ! convect3
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+c ori        ticb(i)=t(i,icb(i))
+c ori        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len              
+         ticb(i)=t(i,icb(i)+1)   
+         gzicb(i)=gz(i,icb(i)+1) 
+         qsicb(i)=qs(i,icb(i)+1) 
+        enddo                   
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv30_trigger(len,nd,icb,plcl,p,th,tv,tvp
+     o                ,pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cv30param.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+c
+c   ***   make sure that column is dry adiabatic between the surface  ***
+c   ***    and cloud base, and that lifted air is positively buoyant  ***
+c   ***                         at cloud base                         ***
+c   ***       if not, return to calling program after resetting       ***
+c   ***                        sig(i) and w0(i)                       ***
+c
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = th(i,1)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv30_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cv30param.h"
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd) 
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+c      do 121 j=1,ntra
+c      do 111 k=1,nd
+c       nn=0
+c      do 101 i=1,len
+c      if(iflag1(i).eq.0)then
+c       nn=nn+1
+c       tra(nn,k,j)=tra1(i,k,j)
+c      endif
+c 101  continue
+c 111  continue
+c 121  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv30_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c 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)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+c ori          if(k.ge.(nk(i)+1))then
+c ori            tca=tp(i,k)-t0
+c ori            if(tca.ge.0.0)then
+c ori              elacrit=elcrit
+c ori            else
+c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+c ori            endif
+c ori            elacrit=max(elacrit,0.0)
+c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+c ori            ep(i,k)=max(ep(i,k),0.0 )
+c ori            ep(i,k)=min(ep(i,k),1.0 )
+c ori            sigp(i,k)=sigs
+c ori          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c===================================================================== 
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k) 
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+cIM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
+       buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+ 510  continue
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+cym      do i=1,ncum*nlp
+cym       hp(i,1)=h(i,1)
+cym      enddo
+
+      do k=1,nlp
+        do i=1,ncum
+	  hp(i,k)=h(i,k)
+	enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end
+
+      SUBROUTINE cv30_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb   
+c -------------------------------------------------------
+      
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=amax1(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+      
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),  
+c -- vertical velocity (w), fractional area covered by    
+c -- undilute updraft (sig), and updraft mass flux (m)  
+c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0 
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+
+
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=amax1(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv30_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+! 	- changer rr(il,1) -> qnk(il)
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c 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)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+cym            ment(i,k,j)=0.0
+cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+c      do k=1,ntra
+c       do j=1,nd  ! instead nlp
+c        do i=1,nd ! instead nlp
+c         do il=1,ncum
+c            traent(il,i,j,k)=tra(il,j,k)
+c         enddo
+c        enddo
+c       enddo
+c      enddo
+      zm(:,:)=0.
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il))
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il))
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+c       do k=1,ntra
+c        do j=minorig,nl
+c         do il=1,ncum
+c          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+c     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+c            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c          endif
+c         enddo
+c        enddo
+c       enddo
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then 
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i)
+      uent(il,i,i)=u(il,nk(il))
+      vent(il,i,i)=v(il,nk(il))
+      elij(il,i,i)=clw(il,i)
+cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+ 
+c      do j=1,ntra
+c       do i=minorig+1,nl
+c        do il=1,ncum
+c         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+c          traent(il,i,i,j)=tra(il,nk(il),j)
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+cym      call zilch(asum,ncum*nd)
+cym      call zilch(bsum,ncum*nd)
+cym      call zilch(csum,ncum*nd)
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl 
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=rr(il,1)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=u(il,nk(il))
+        vent(il,i,i)=v(il,nk(il))
+        elij(il,i,i)=clw(il,i)
+cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+c     :     .and. csum(il,i).lt.m(il,i) ) then
+c         traent(il,i,i,j)=tra(il,nk(il),j)
+c        endif
+c       enddo
+c      enddo
+789   continue
+c      
+c MAF: renormalisation de MENT
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+
+      SUBROUTINE cv30_unsat(nloc,ncum,nd,na,ntra,icb,inb
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl
+     :              ,mp,rp,up,vp,trap,wt,water,evap,b)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real th(nloc,na), gz(nloc,na)
+      real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real cpn(nloc,na), tv(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na)
+
+c local variables
+      integer i,j,k,il,num1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+
+c        do k=1,ntra
+c         do i=1,nd
+c          do il=1,ncum
+c           trap(il,i,k)=tra(il,i,k)
+c          enddo
+c         enddo
+c        enddo
+
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+ 
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+
+c
+c    ***                    begin downdraft loop                    ***
+c
+
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd*wt(il,i))
+c
+cjyg1
+ccc        sigt=1.0
+ccc        if(i.ge.icb)sigt=sigp(i)
+c prise en compte de la variation progressive de sigt dans
+c les couches icb et icb-1:
+c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+c 	pour plcl>ph(i),   pr1=1 & pr2=0
+c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+c    sur le nuage, et pr2 est la proportion sous la base du
+c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+      b6=bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :                -50.*sigd*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)
+     :            +0.02*(wdtrain(il)+sigd*wt(il,i)*water(il,i+1))
+     :                 /(sigd*(ph(il,i)-ph(il,i+1)))
+      end if
+c
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd*tevap
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+      endif
+c
+c    ***           if hydrostatic assumption fails,             ***
+c    ***   solve cubic difference equation for downdraft theta  ***
+c    ***  and mass flux from two simultaneous differential eqns ***
+c
+      amfac=sigd*sigd*70.0*ph(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,i))*xf*tevap
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante: 
+C il faut diviser par (mp(il,i)*sigd*grav) et non par (mp(il,i)+sigd*0.1). 
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+      if(p(il,i).gt.p(il,icb(il)))then
+       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+      endif
+
+360   continue
+      endif ! i.eq.1
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+c      do j=1,ntra
+c      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+ctestmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+c     :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
+c      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+c      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+c       do j=1,ntra
+c       trap(il,i,j)=trap(il,i+1,j)
+c       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end
+
+      SUBROUTINE cv30_yield(nloc,ncum,nd,na,ntra 
+     :                    ,icb,inb,delt
+     :                    ,t,rr,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b
+     :                    ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                    ,tv,tvp
+     :                    ,iflag,precip,VPrecip,ft,fr,fu,fv,ftra
+     :                    ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      implicit none
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+cym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mike(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, awat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+
+      do il=1,ncum
+       precip(il)=0.0
+       wd(il)=0.0     ! gust
+       VPrecip(il,nd+1)=0.
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         VPrecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+
+c      do j=1,ntra
+c       do i=1,nd
+c        do il=1,ncum
+c          ftra(il,i,j)=0.0
+c        enddo
+c       enddo 
+c      enddo
+
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum 
+       if(ep(il,inb(il)).ge.0.0001)then 
+        if (cvflag_grav) then
+         precip(il)=wt(il,1)*sigd*water(il,1)*86400.*1000./(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd*water(il,1)*8640.
+        endif
+       endif 
+      enddo 
+
+C   ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
+C
+c MAF rajout pour lessivage
+       do k=1,nl
+         do il=1,ncum
+          if (k.le.inb(il)) then
+            if (cvflag_grav) then
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/grav
+            else
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/10.
+            endif 
+          endif
+         end do
+       end do
+C
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       am(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.le.inb(il)) then
+         am(il)=am(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+      do il=1,ncum
+
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+
+      ft(il,1)=ft(il,1)-0.5*lvcp(il,1)*sigd*(evap(il,1)+evap(il,2))
+
+      if (cvflag_grav) then
+       ft(il,1)=ft(il,1)-0.009*grav*sigd*mp(il,2)
+     :                             *t(il,1)*b(il,1)*work(il)
+      else
+       ft(il,1)=ft(il,1)-0.09*sigd*mp(il,2)*t(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd*wt(il,1)*(cl-cpd)*water(il,2)*(t(il,2)
+     :-t(il,1))*work(il)/cpn(il,1)
+
+      if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+c (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap) 
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+c+tard     :          +sigd*evap(il,1)
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      endif ! cvflag_grav
+
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (cvflag_grav) then
+c         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        else
+c         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        endif
+c       enddo
+c      enddo
+
+      do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il)) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+c      do k=1,ntra
+c       do j=2,nl
+c        do il=1,ncum
+c         if (j.le.inb(il)) then
+
+c          if (cvflag_grav) then
+c           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          else
+c           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          endif
+
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+c
+c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il))num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=i+1,nl+1
+       do 441 il=1,ncum
+        if (i.le.inb(il) .and. k.le.(inb(il)+1)) then
+         amp1(il)=amp1(il)+m(il,k)
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il)) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+      if (cvflag_grav) then
+       ft(il,i)=0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      else  ! cvflag_grav
+       ft(il,i)=0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      endif ! cvflag_grav
+
+
+      ft(il,i)=ft(il,i)+0.01*sigd*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t(il,i+1)-t(il,i))*dpinv*cpinv
+
+      if (cvflag_grav) then
+       fr(il,i)=0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+c      do k=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+c         if (cvflag_grav) then
+c           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         else
+c           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         endif
+c        endif
+c       enddo
+c      enddo
+
+      do 480 k=1,i-1
+       do 1370 il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+      awat=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+      awat=amax1(awat,0.0)
+
+      if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+c      do j=1,ntra
+c       do k=1,i-1
+c        do il=1,ncum
+c         if (i.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 490 k=i,nl+1
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav 
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav 
+        endif ! i and k
+1380   continue
+490   continue
+
+c      do j=1,ntra
+c       do k=i,nl+1
+c        do il=1,ncum
+c         if (i.le.inb(il) .and. k.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :         *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :             *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif ! i and k
+c        enddo
+c       enddo
+c      enddo
+
+      do 1400 il=1,ncum
+       if (i.le.inb(il)) then
+        dpinv=1.0/(ph(il,i)-ph(il,i+1))
+        cpinv=1.0/cpn(il,i)
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+
+         fu(il,i)=fu(il,i)+0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+         fu(il,i)=fu(il,i)+0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+      endif ! i
+1400  continue
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum 
+        if (k.le.inb(il) .and. i.le.inb(il)) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0.) then    ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+
+c         if (cvflag_grav) then
+c          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         else
+c          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         endif
+c        endif ! i
+c       enddo
+c      enddo 
+
+500   continue
+
+
+c   ***   move the detrainment at level inb down to level inb-1   ***
+c   ***        in such a way as to preserve the vertically        ***
+c   ***          integrated enthalpy and water tendencies         ***
+c
+      do 503 il=1,ncum
+
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))
+     : +t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+503   continue
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        ex=0.1*ment(il,inb(il),inb(il)) 
+c     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+c     :      /(ph(il,inb(il))-ph(il,inb(il)+1))
+c        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+c        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+c     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+c     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+c       enddo
+c      enddo
+
+c
+c   ***    homoginize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif 
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+      
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+m(il,k)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!     
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mike(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mike(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        icb represente de niveau ou se trouve la
+c        base du nuage , et inb le top du nuage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 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)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il) ) then                       ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+            
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0)                               ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+cIM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)              ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+        return
+        end
+
+      SUBROUTINE cv30_tracer(nloc,len,ncum,nd,na,
+     &                        ment,sij,da,phi)
+        implicit none
+c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sij(nloc,na,na)
+c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+c local variables:
+        integer i,j,k
+c        
+        da(:,:)=0.
+c
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+            da(i,j)=da(i,j)+(1.-sij(i,k,j))*ment(i,k,j)
+            phi(i,j,k)=sij(i,k,j)*ment(i,k,j)
+c            print *,'da',j,k,da(i,j),sij(i,k,j),ment(i,k,j)
+            end do 
+          end do 
+        end do 
+    
+        return
+        end
+
+
+      SUBROUTINE cv30_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,VPrecip,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,inb
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,da,phi,mp
+     :         ,iflag1
+     :         ,precip1,VPrecip1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,inb1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :         ,da1,phi1,mp1)
+      implicit none
+
+#include "cv30param.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      integer inb(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+      real da(nloc,nd),phi(nloc,nd,nd),mp(nloc,nd)
+
+c outputs:
+      integer iflag1(len)
+      integer inb1(len)
+      real precip1(len)
+      real VPrecip1(len,nd+1)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+      real da1(nloc,nd),phi1(nloc,nd,nd),mp1(nloc,nd)
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         inb1(idcum(i))=inb(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            VPrecip1(idcum(i),k)=VPrecip(i,k)
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            da1(idcum(i),k)=da(i,k)
+            mp1(idcum(i),k)=mp(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+c        do 2100 j=1,ntra
+c         do 2110 k=1,nd ! oct3
+c          do 2120 i=1,ncum
+c            ftra1(idcum(i),k,j)=ftra(i,k,j)
+c 2120     continue
+c 2110    continue
+c 2100   continue
+        do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            phi1(idcum(i),k,j)=phi(i,k,j)
+          end do
+         end do
+        end do
+
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv30param.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv30param.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv30param.h	(revision 984)
@@ -0,0 +1,30 @@
+!
+! $Header$
+!
+c------------------------------------------------------------
+c Parameters for convectL, iflag_con=30:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigd, spfac
+cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE   real pbcrit, ptcrit, epmax
+      real pbcrit, ptcrit
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha
+      real delta
+      real betad
+
+      COMMON /cv30param/  noff, minorig, nl, nlp, nlm
+     :                ,  sigd, spfac
+cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE  :                ,pbcrit, ptcrit, epmax
+     :                ,pbcrit, ptcrit
+     :                ,omtrain
+     :                ,dtovsh, dpbase, dttrig
+     :                ,dtcrit, tau, beta, alpha, delta, betad
+
+c$OMP THREADPRIVATE(/cv30param/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_buoy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_buoy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_buoy.F	(revision 984)
@@ -0,0 +1,145 @@
+        SUBROUTINE CV3_BUOY (nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,Ale,Cin
+     :                      ,tv,tvp
+     :                      ,buoy )
+***************************************************************
+*                                                             *
+* CV3_BUOY                                                    *
+*         Buoyancy corrections to account for ALE             *
+*                                                             *
+* written by   : MOREAU Cecile, 07/08/2003, 15.55.48          *
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real Ale(nloc), Cin(nloc)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c output:
+      real buoy(nloc,nd)
+
+c local variables:
+      integer il, k
+      integer kmx(nloc)
+      real bll(nloc), bmx(nloc)
+      real gamma(nloc)
+      real dgamma
+      real buoymin
+      logical ok(nloc)
+
+      data dgamma /2.e-03/ !dgamma gamma
+      data buoymin /2./
+
+      logical fixed_bll
+      SAVE fixed_bll
+      data fixed_bll /.TRUE./
+c$OMP THREADPRIVATE(fixed_bll)
+
+
+c      print *,' Ale+cin ',ale(1)+cin(1)
+c--------------------------------------------------------------
+c      Recompute buoyancies
+c--------------------------------------------------------------
+      DO k = 1,nl
+        DO il = 1,ncum
+           buoy(il,k) = tvp(il,k) - tv(il,k)
+        ENDDO
+      ENDDO
+
+c -------------------------------------------------------------
+c -- Compute low level buoyancy ( function of Ale+Cin )
+c -------------------------------------------------------------
+      IF (fixed_bll) THEN
+c
+      do il = 1,ncum
+        bll(il) = 0.5
+      end DO
+      else
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        gamma(il) = 4.*buoy(il,icb(il))**2
+     :           + 8.*dgamma*(Ale(il)+Cin(il))*tv(il,icb(il))/grav
+        gamma(il) = max(gamma(il),1.e-10)
+       ENDIF
+      end do
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = 4.*dgamma*(Ale(il)+Cin(il))*tv(il,icb(il))
+     :         /(grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il)))))
+       ENDIF
+      end do
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = min(bll(il),buoymin)
+       ENDIF
+      end DO
+c
+      ENDIF     !(fixed_bll)
+
+
+c -------------------------------------------------------------
+c --Get highest buoyancy among levels below LCL-200hPa
+c -------------------------------------------------------------
+
+      do il = 1,ncum
+       bmx(il) =-1000.
+       kmx(il) = icb(il)
+       ok(il) = .true.
+      end do
+
+      do k = 1,nl
+       do il = 1,ncum
+        IF (Ale(il)+Cin(il) .GT. 0. .AND. ok(il)) THEN
+        IF (k .GT. icb(il) .AND. k .LE. inb(il)) THEN
+cc         print *,'k,p(il,k),plcl(il)-200. ', k,p(il,k),plcl(il)-200.
+         IF (P(il,k) .GT. plcl(il)-200.) THEN
+          IF (buoy(il,k) .GT. bmx(il)) THEN
+           bmx(il) = buoy(il,k)
+           kmx(il) = k
+           IF (bmx(il) .GE. bll(il)) ok(il)=.false.
+          ENDIF
+         ENDIF
+        ENDIF
+        ENDIF
+       end do
+      end do
+
+c      print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) '
+c     $       ,bll(1),bmx(1),icb(1),kmx(1)
+
+c -------------------------------------------------------------
+c --Calculate modified buoyancies
+c -------------------------------------------------------------
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = min(bll(il),bmx(il))
+       ENDIF
+      end do
+
+      do k = 1,nl
+       do il = 1,ncum
+        IF (Ale(il)+Cin(il) .GT. 0.) THEN
+         IF (k .GE. icb(il) .AND. k .LE. kmx(il)-1) THEN
+           buoy(il,k) = bll(il)
+         ENDIF
+        ENDIF
+       end do
+      end do
+
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_cine.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_cine.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_cine.F	(revision 984)
@@ -0,0 +1,449 @@
+        SUBROUTINE cv3_cine(nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,tv,tvp
+     :                      ,cina,cinb)
+
+***************************************************************
+*                                                             *
+* CV3_CINE                                                    *
+*                                                             *
+*                                                             *
+* written by   :   Frederique Cheruy                          *
+* vectorization:   Jean-Yves Grandpeix, 19/06/2003, 11.54.43  *
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+c
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "cv3param.h"
+c 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)
+c
+c output
+      real cina(nloc),cinb(nloc)
+c
+c local variables
+      integer il,i,j,k
+      integer itop(nloc),ineg(nloc),ilow(nloc)
+      integer ifst(nloc),isublcl(nloc)
+      logical lswitch(nloc),lswitch1(nloc),lswitch2(nloc)
+      real dpmax
+      real deltap,dcin
+      real buoylcl(nloc),tvplcl(nloc),tvlcl(nloc)
+      real plfc(nloc),p0(nloc)
+      real buoyz(nloc), buoy(nloc,nd)
+c
+c-------------------------------------------------------------
+c     Initialization
+c-------------------------------------------------------------
+      do il = 1,ncum
+       cina(il) = 0.
+       cinb(il) = 0.
+      enddo
+c
+c--------------------------------------------------------------
+c      Recompute buoyancies
+c--------------------------------------------------------------
+      DO k = 1,nl
+        DO il = 1,ncum
+          buoy(il,k) = tvp(il,k) - tv(il,k)
+        ENDDO
+      ENDDO
+c
+c---------------------------------------------------------------
+c premiere couche contenant un  niveau de flotabilite positive
+c et premiere couche contenant un  niveau de flotabilite negative
+c  au dessus du niveau de condensation
+c---------------------------------------------------------------
+      do il = 1,ncum
+        itop(il) =nl-1
+        ineg(il) = nl-1
+      enddo
+      do 100 k=nl,1,-1
+       do 110 il=1,ncum
+        if (k .ge. icb(il)) then
+         if (buoy(il,k) .gt. 0.) then
+          itop(il)=k
+         else
+          ineg(il)=k
+         endif
+        endif
+110    continue
+100   continue
+c      print *,' itop, ineg, icb ',itop(1),ineg(1), icb(1)
+c
+c---------------------------------------------------------------
+c
+c   calcul de la flottabilite a LCL (Buoylcl)
+c     ifst = first P-level above lcl
+c     isublcl = highest P-level below lcl.
+c---------------------------------------------------------------
+c
+      do il = 1,ncum
+       TVPlcl(il) = TVP(il,1)*(Plcl(il)/P(il,1))**(2./7.) !For dry air, R/Cp=2/7
+      enddo
+c
+      do il = 1,ncum
+       IF (Plcl(il) .GT. P(il,icb(il))) THEN
+        ifst(il) = icb(il)
+        isublcl(il) = icb(il)-1
+       ELSE
+        ifst(il) = icb(il)+1
+        isublcl(il) = icb(il)
+       ENDIF
+      enddo
+c
+      do il = 1,ncum
+       TVlcl(il)=TV(il,ifst(il)-1)+(TV(il,ifst(il))-TV(il,ifst(il)-1))
+     $   *(Plcl(il)-P(il,ifst(il)-1))/(P(il,ifst(il))-P(il,ifst(il)-1))
+      enddo
+c
+      do il = 1,ncum
+        BUOYlcl(il) = TVPlcl(il)-TVlcl(il)
+      enddo
+c
+c---------------------------------------------------------------
+c -- Two cases : BUOYlcl >= 0 and BUOYlcl < 0.
+c---------------------------------------------------------------
+C
+C--------------------
+C -- 1.0 BUOYlcl >=0.
+C--------------------
+c
+      DPMAX = 50.
+      DO il = 1,ncum
+        lswitch1(il)=BUOYlcl(il) .GE. 0.
+        lswitch(il) = lswitch1(il)
+      ENDDO
+c
+c 1.1 No inhibition case
+c ----------------------
+C   If buoyancy is positive at LCL and stays positive over a large enough
+C pressure interval (=DPMAX), inhibition is set to zero,
+C
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        IF (P(il,ineg(il)) .LT. P(il,icb(il))-DPmax) THEN
+          PLFC(il) = Plcl(il)
+          Cina(il) = 0.
+          Cinb(il) = 0.
+        ENDIF
+      ENDIF
+      ENDDO
+c
+c 1.2 Upper inhibition only case
+c ------------------------------
+      DO il = 1,ncum
+        lswitch2(il)= P(il,ineg(il)) .GE. P(il,icb(il))-DPmax
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+          Cinb(il) = 0.
+c
+c 1.2.1  Calcul de la pression du niveau de flot. nulle juste au-dessus de LCL
+c ---------------------------------------------------------------------------
+         IF (ineg(il) .GT. isublcl(il)+1) THEN
+C In order to get P0, one may interpolate linearly buoyancies
+C  between P(ineg) and P(ineg-1).
+        P0(il)=(buoy(il,ineg(il))*P(il,ineg(il)-1)
+     $         -buoy(il,ineg(il)-1)*P(il,ineg(il)))
+     :           / (buoy(il,ineg(il))-buoy(il,ineg(il)-1))
+         ELSE
+C In order to get P0, one has to interpolate between P(ineg) and Plcl.
+        P0(il) = (BUOY(il,ineg(il))*Plcl(il)-BUOYlcl(il)*P(il,ineg(il)))
+     $          /(BUOY(il,ineg(il))     -BUOYlcl(il))
+         ENDIF
+      ENDIF
+      ENDDO
+c
+c 1.2.2 Recompute itop (=1st layer with positive buoyancy above ineg)
+c -------------------------------------------------------------------
+      do il = 1,ncum
+      IF (lswitch(il)) THEN
+        itop(il) =nl-1
+      ENDIF
+      enddo
+c
+      do  k=nl,1,-1
+       do  il=1,ncum
+       IF (lswitch(il)) THEN
+        if (k .ge. ineg(il) .and. buoy(il,k) .gt. 0) then
+         itop(il)=k
+        endif
+       ENDIF
+       enddo
+      enddo
+c
+c 1.2.3 Computation of PLFC
+c -------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il)=(buoy(il,itop(il))*P(il,itop(il)-1)
+     $           -buoy(il,itop(il)-1)*P(il,itop(il)))
+     $           / (buoy(il,itop(il))-buoy(il,itop(il)-1))
+      ENDIF
+      ENDDO
+c
+c 1.2.4 Computation of CINA
+c -------------------------
+c
+C   Upper part of CINA : integral from P(itop-1) to Plfc
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,itop(il)-1)-Plfc(il)
+        dcin = RD*BUOY(il,itop(il)-1)*deltap
+     $        / (P(il,itop(il)-1)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+C   Middle part of CINA : integral from P(ineg) to P(itop-1)
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)) THEN
+          IF (k .GE. ineg(il) .AND. k .LE. itop(il)-2) THEN
+           deltap = P(il,k)-P(il,k+1)
+           dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+           CINA(il) = CINA(il) + min(0.,dcin)
+          ENDIF
+        ENDIF
+        ENDDO
+      ENDDO
+c
+C   Lower part of CINA : integral from P0 to P(ineg)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-P(il,ineg(il))
+        dcin = RD*BUOY(il,ineg(il))*deltap/(P(il,ineg(il))+P0(il))
+        CINA(il) = CINA(il) + min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+C
+C ------------------
+C -- 2.0 BUOYlcl <0.
+C ------------------
+C
+      DO il = 1,ncum
+        lswitch1(il)=BUOYlcl(il) .LT. 0.
+        lswitch(il) = lswitch1(il)
+      ENDDO
+c
+c 2.0.1 Premiere  couche ou la flotabilite est negative au dessus du sol
+c ----------------------------------------------------
+c    au cas ou il existe  sinon ilow=1 (nk apres)
+c      on suppose que la parcelle part de la premiere couche
+c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+       ilow(il)=1
+      ENDIF
+      ENDDO
+c
+      do 200 i=nl,1,-1
+        DO il = 1,ncum
+        IF (lswitch(il) .AND. k .LE.icb(il)-1) THEN
+         if(buoy(il,k).lt. 0.) then
+           ilow(il) = k
+          endif
+        ENDIF
+        ENDDO
+ 200  continue
+
+c 2.0.2  Calcul de la pression du niveau de flot. nulle sous le nuage
+c ----------------------------------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+       if(ilow(il).gt. 1) then
+         P0(il)=(buoy(il,ilow(il))*P(il,ilow(il)-1)
+     $          -buoy(il,ilow(il)-1)*P(il,ilow(il)))
+     :            / (buoy(il,ilow(il))-buoy(il,ilow(il)-1))
+         BUOYz(il) = 0.
+       else
+         P0(il) = P(il,1)
+         BUOYz(il) = BUOY(il,1)
+       endif
+      ENDIF
+      ENDDO
+c
+C 2.1. Computation of CINB
+C -----------------------
+c
+      DO il = 1,ncum
+        lswitch2(il)= (isublcl(il) .EQ. 1 .AND. ilow(il) .EQ. 1)
+     $                  .OR.(isublcl(il) .EQ. ilow(il)-1)
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+cc      IF (    (isublcl .EQ. 1 .AND. ilow .EQ. 1)
+cc     $    .OR.(isublcl .EQ. ilow-1)) THEN
+c
+c 2.1.1 First case : Plcl just above P0
+c -------------------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-Plcl(il)
+        dcin = RD*(BUOYz(il)+BUOYlcl(il))*deltap/(P0(il)+Plcl(il))
+        CINB(il) = min(0.,dcin)
+cc        print *,'buoyz(il),buoylcl(il),deltap,p0(il),plcl(il),dcin ',
+cc     $           buoyz(il),buoylcl(il),deltap,p0(il),plcl(il),dcin
+      ENDIF
+      ENDDO
+c        print*, 'CINB ',CINB(1),'DCIN ',DCIN,I,BUOYz(1),BUOYlcl(1)
+c
+      DO il = 1,ncum
+        lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+      ENDDO
+cc      ELSE
+c
+c 2.1.2 Second case : there is at least one P-level between P0 and Plcl
+c ---------------------------------------------------------------------
+c
+C   Lower part of CINB : integral from P0 to P(ilow)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-P(il,ilow(il))
+        dcin = RD*(BUOYz(il)+BUOY(il,ilow(il)))*deltap
+     $         /(P0(il)+P(il,ilow(il)))
+        CINB(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+      IF (lswitch(1)) THEN
+c        print*,'ilow= ',ilow(1),'DCIN0 ',DCIN,P0(1),P(1,ilow(1))
+c        print*,'buoy',(BUOY(1,k),k=1,itop(1))
+      ENDIF
+c
+C  Middle part of CINB : integral from P(ilow) to P(isublcl)
+cc      DO k = ilow,isublcl-1
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)
+     $   .AND. k .GE. ilow(il) .AND. k .LE. isublcl(il)-1) THEN
+          deltap = P(il,k)-P(il,k+1)
+          dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+          CINB(il) = CINB(il) + min(0.,dcin)
+        ENDIF
+        ENDDO
+c      print*, 'CINB ', CINB(1), 'DCIN',DCIN,k,BUOY(1,k),BUOY(1,k+1)
+      ENDDO
+c
+C  Upper part of CINB : integral from P(isublcl) to Plcl
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,isublcl(il)) - Plcl(il)
+        dcin = RD*(BUOY(il,isublcl(il))+BUOYlcl(il))*deltap
+     $         /(P(il,isublcl(il))+Plcl(il))
+        CINB(il) = CINB(il)+min(0.,dcin)
+      ENDIF
+      ENDDO
+C
+c        print*, ' CINB ', CINB(1), 'Dcin ',dcin
+c
+cc      ENDIF
+c
+C 2.2 Computation of CINA
+c ---------------------
+c
+      DO il = 1,ncum
+        lswitch2(il)= Plcl(il) .GT. P(il,itop(il)-1)
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+c
+c 2.2.1 FIrst case : Plcl > P(itop-1)
+C ---------------------------------
+C In order to get Plfc, one may interpolate linearly buoyancies
+C  between P(itop) and P(itop-1).
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il)=(buoy(il,itop(il))*P(il,itop(il)-1)
+     $           -buoy(il,itop(il)-1)*P(il,itop(il)))
+     $           / (buoy(il,itop(il))-buoy(il,itop(il)-1))
+      ENDIF
+      ENDDO
+c
+C   Upper part of CINA : integral from P(itop-1) to Plfc
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,itop(il)-1)-Plfc(il)
+        dcin = RD*BUOY(il,itop(il)-1)*deltap
+     $         /(P(il,itop(il)-1)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+C   Middle part of CINA : integral from P(icb+1) to P(itop-1)
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)
+     $     .AND. k .GE. icb(il)+1 .AND. k .LE. itop(il)-2) THEN
+          deltap = P(il,k)-P(il,k+1)
+          dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+          CINA(il) = CINA(il) + min(0.,dcin)
+        ENDIF
+        ENDDO
+      ENDDO
+c
+C   Lower part of CINA : integral from Plcl to P(icb+1)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        IF (Plcl(il) .GT. P(il,icb(il))) THEN
+          IF (icb(il) .LT. itop(il)-1) THEN
+            deltap = P(il,icb(il))-P(il,icb(il)+1)
+            dcin = 0.5*RD*(BUOY(il,icb(il))+BUOY(il,icb(il)+1))
+     $                   *deltap/PH(il,icb(il)+1)
+            CINA(il) = CINA(il)+min(0.,dcin)
+          ENDIF
+c
+          deltap = Plcl(il)-P(il,icb(il))
+          dcin = RD*(BUOYlcl(il)+BUOY(il,icb(il)))
+     $              *deltap/(Plcl(il)+P(il,icb(il)))
+          CINA(il) = CINA(il)+min(0.,dcin)
+        ELSE
+          deltap = Plcl(il)-P(il,icb(il)+1)
+          dcin = RD*(BUOYlcl(il)+BUOY(il,icb(il)+1))
+     $             *deltap/(Plcl(il)+P(il,icb(il)+1))
+          CINA(il) = CINA(il)+min(0.,dcin)
+        ENDIF
+      ENDIF
+      ENDDO
+c
+      DO il = 1,ncum
+        lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+      ENDDO
+cc      ELSE
+c
+c 2.2.2 Second case : Plcl lies between P(itop-1) and P(itop);
+C ----------------------------------------------------------
+C In order to get Plfc, one has to interpolate between P(itop) and Plcl.
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il) =
+     $    (BUOY(il,itop(il))*Plcl(il)-BUOYlcl(il)*P(il,itop(il)))
+     $          /(BUOY(il,itop(il))     -BUOYlcl(il))
+      ENDIF
+      ENDDO
+c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = Plcl(il)-Plfc(il)
+        dcin = RD*BUOYlcl(il)*deltap/(Plcl(il)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+cc      ENDIF
+c       Print *,' Plcl,P(itop-1),P(itop),PLFC,BUOYlcl'
+c     $      ,Plcl(1),P(1,itop(1)-1),P(1,itop(1)),PLFC(1),BUOYlcl(1)
+C
+c        print*, 'CIN above', CINA(1), 'CIN below',CINB(1)
+c
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_crit.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_crit.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_crit.F	(revision 984)
@@ -0,0 +1,61 @@
+        SUBROUTINE CV3_CRIT (nloc,ncum,nd,icb,inb,p,ph,pzero
+     $             ,v,threshold,kcrit,pcrit)
+***************************************************************
+*                                                             *
+* CV3_CRIT   Find pressure level where vertical profile of    *
+*            variable 'v' intersects 'threshold'              *
+*                                                             *
+* written by   : FROHWIRTH Julie, 13/08/2003, 21.55.12        *
+* modified by :                                               *
+***************************************************************
+*
+
+#include "cv3param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real pzero(nloc)
+      real v(nloc,nd),threshold
+
+c output:
+      integer kcrit(nloc)
+      real pcrit(nloc)
+
+c local variables
+      integer i,j,k,il
+      logical ok(nloc)
+
+      do il = 1,ncum
+        ok(il) = .true.
+        pcrit(il) = -1.
+        kcrit(il) = 0
+      enddo
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .AND. ok(il)) THEN
+          IF ( (v(il,i)-threshold)*(v(il,i-1)-threshold) .LT. 0.) THEN
+            pcrit(il) =
+     $       ((threshold-v(il,i))*P(il,i-1)-
+     $        (threshold-v(il,i-1))*P(il,i))
+     $           /(v(il,i-1)-v(il,i))
+           IF (pcrit(il) .gt. Pzero(il)) THEN
+            pcrit(il) = -1.
+           ELSE
+            ok(il) = .false.
+            kcrit(il) = i
+            IF (pcrit(il) .LT. PH(il,i)) kcrit(il) = kcrit(il)+1
+           ENDIF
+          ENDIF  ! end IF (v(i) ...
+        ENDIF    ! end IF (P(i) ...
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+125   CONTINUE
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_inicp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_inicp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_inicp.F	(revision 984)
@@ -0,0 +1,114 @@
+        SUBROUTINE cv3_inicp()
+*
+***************************************************************
+*                                                             *
+* CV3_INIP Lecture des choix de lois de probabilité de mélange*
+*          et calcul de leurs coefficients normalisés.        *
+*                                                             *
+* written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27    *
+* modified by :                                               *
+***************************************************************
+*
+#include "YOMCST2.h"
+c
+      INTEGER iflag_clos
+c
+c --   Mixing probability distribution functions
+c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *
+     $            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/
+     $           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))
+     1             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+C
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+C
+C===========================================================================
+C    	READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
+C	AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
+C       (Written by V.T.J. Phillips, 20-30/Jan/99)
+C===========================================================================
+C
+C   line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F) is to be
+C         used, followed by SCUT, which is the cut-off value of F in CONVECT
+C   line 2:  blank
+C   line 3:  the coefficients for the linear combination of P(F)s to
+C                 make the general P(F)
+C   line 4:  blank
+C   line 5:  gammas, Fmax for the cosh^2 component of P(F)
+C   line 6:  blank
+C   line 7:  alphas for the 1st irrational P(F)
+C   line 8:  blank
+C   line 9:  betas  for the 2nd irrational P(F)
+C
+
+c        open(57,file='parameter_mix.data')
+
+c        read(57,*) iflag_clos
+c        read(57,*) iflag_mix, scut
+c        read(57,*)
+c        if(iflag_mix .gt. 0) then
+c	      read(57,*) qqa1, qqa2
+c              read(57,*)
+c              read(57,*) gammas, Fmax
+c              read(57,*)
+c              read(57,*) alphas
+c         endif
+c	 close(57)
+c
+      if(iflag_mix .gt. 0) then
+c
+c--      Normalize Pdf weights
+c
+        sumcoef=qqa1+qqa2
+        qqa1=qqa1/sumcoef
+        qqa2=qqa2/sumcoef
+c
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+c
+        sigma = 0.
+        aire=0.0
+        pdf=0.0
+        mu=0.0
+        df = 0.0001
+c
+c        do ff = 0.0 + df, 1.0 - 2.*df, df
+         ff=df
+         dowhile ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df) -  Qmix(ff)) * (1.-ff) / df
+              aire=aire+(Qmix(ff+df) - Qmix(ff)) * (1.-ff)
+              mu = mu + pdf * ff * df
+cc              write(*,*) pdf,  Qmix(ff), aire, ff
+         ff=ff+df
+         enddo
+c
+c         do ff=0.0+df,1.0 - 2.*df,df
+         ff=df
+         dowhile ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df)- Qmix(ff)) * (1.-ff) / df
+              sigma = sigma+pdf*(ff - mu)*(ff - mu)*df
+         ff=ff+df
+         enddo
+         sigma = sqrt(sigma)
+c
+        if (abs(aire-1.0) .gt. 0.02) then
+            print *,'WARNING:: AREA OF MIXING PDF IS::', aire
+            stop
+        else
+            print *,'Area, mean & std deviation are ::', aire,mu,sigma
+        endif
+      endif     !  (iflag_mix .gt. 0)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_inip.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_inip.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_inip.F	(revision 984)
@@ -0,0 +1,113 @@
+        SUBROUTINE cv3_inip()
+***************************************************************
+*                                                             *
+* CV3_INIP Lecture des choix de lois de probabilité de mélange*
+*          et calcul de leurs coefficients normalisés.        *
+*                                                             *
+* written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27    *
+* modified by :                                               *
+***************************************************************
+*
+#include "YOMCST2.h"
+c
+c      INTEGER iflag_mix
+c
+c --   Mixing probability distribution functions
+c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *
+     $            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/
+     $           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))
+     1             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+C
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+C
+C===========================================================================
+C    	READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
+C	AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
+C       (Written by V.T.J. Phillips, 20-30/Jan/99)
+C===========================================================================
+C
+C   line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F) is to be
+C         used, followed by SCUT, which is the cut-off value of F in CONVECT
+C   line 2:  blank
+C   line 3:  the coefficients for the linear combination of P(F)s to
+C                 make the general P(F)
+C   line 4:  blank
+C   line 5:  gammas, Fmax for the cosh^2 component of P(F)
+C   line 6:  blank
+C   line 7:  alphas for the 1st irrational P(F)
+C   line 8:  blank
+C   line 9:  betas  for the 2nd irrational P(F)
+C
+
+c$$$        open(57,file='parameter_mix.data')
+c$$$
+c$$$        read(57,*) iflag_mix, scut
+c$$$        read(57,*)
+c$$$        if(iflag_mix .gt. 0) then
+c$$$	      read(57,*) qqa1, qqa2
+c$$$              read(57,*)
+c$$$              read(57,*) gammas, Fmax
+c$$$              read(57,*)
+c$$$              read(57,*) alphas
+c$$$         endif
+c$$$	 close(57)
+
+c
+      if(iflag_mix .gt. 0) then
+c
+c--      Normalize Pdf weights
+c
+        sumcoef=qqa1+qqa2
+        qqa1=qqa1/sumcoef
+        qqa2=qqa2/sumcoef
+c
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+c
+        sigma = 0.
+        aire=0.0
+        pdf=0.0
+        mu=0.0
+        df = 0.0001
+c
+c        do ff = 0.0 + df, 1.0 - 2.*df, df
+         ff=df
+         dowhile ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df) -  Qmix(ff)) * (1.-ff) / df
+              aire=aire+(Qmix(ff+df) - Qmix(ff)) * (1.-ff)
+              mu = mu + pdf * ff * df
+              write(*,*) pdf,  Qmix(ff), aire, ff
+         ff=ff+df
+         enddo
+c
+c         do ff=0.0+df,1.0 - 2.*df,df
+          ff=df
+          dowhile ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df)- Qmix(ff)) * (1.-ff) / df
+              sigma = sigma+pdf*(ff - mu)*(ff - mu)*df
+         ff=ff+df
+         enddo
+         sigma = sqrt(sigma)
+c
+        if (abs(aire-1.0) .gt. 0.02) then
+            print *,'WARNING:: AREA OF MIXING PDF IS::', aire
+            stop
+        else
+            print *,'Area, mean & std deviation are ::', aire,mu,sigma
+        endif
+      endif     !  (iflag_mix .gt. 0)
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_mixscale.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_mixscale.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_mixscale.F	(revision 984)
@@ -0,0 +1,29 @@
+        SUBROUTINE cv3_mixscale(nloc,ncum,na,ment,m)
+***************************************************************
+*                                                             *
+* CV3_MIXSCALE                                                *
+*                                                             *
+*                                                             *
+* written by   : Jean-Yves Grandpeix, 30/05/2003, 16.34.37    *
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+
+#include "cv3param.h"
+
+      integer nloc,ncum,na
+      integer i,j,il
+      real ment(nloc,na,na),m(nloc,na)
+c
+      do 100 j=1,nl
+        do 101 i=1,nl
+          do 102 il=1,ncum
+             ment(il,i,j) = m(il,i)*ment(il,i,j)
+102      continue
+101    continue
+100   continue
+
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_routines.F	(revision 984)
@@ -0,0 +1,3355 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE cv3_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+C   ***                        OF CLOUD                         ***
+C
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+C
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cv3param.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+c -- "microphysical" parameters:
+       sigdz=0.01
+c      sigd=0.003
+c     sigd   = 0.01
+cCR:test sur la fraction des descentes precipitantes
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+      epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+ccc      dttrig = 5.   ! (loose) condition for triggering
+      dttrig = 10.   ! (loose) condition for triggering
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+c      dtcrit = -5.0
+c      tau    = 3000.
+cc      tau = 1800.
+      tau=8000.
+      beta   = 1.0 - delt/tau
+      alpha1 = 1.5e-3
+      alpha  = alpha1 * delt/tau
+c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end
+
+      SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+
+c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+c
+cc        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
+c
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_feed(len,nd,t,q,u,v,p,ph,hm,gz
+     :                  ,p1feed,p2feed,wght
+     :                  ,wghti,tnk,thnk,qnk,qsnk,unk,vnk
+     :                  ,cpnk,hnk,nk,icb,icbmax,iflag,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cv3param.h"
+#include "cvthermo.h"
+
+c inputs:
+	  integer len, nd
+      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)
+c,  wght(len)
+      real wght(nd)
+c input-output
+      real p2feed(len)
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+c      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)
+
+c local variables:
+      integer i, k, iter, niter
+      integer ihmin(len)
+      real work(len)
+      real pup(len),plo(len),pfeed(len)
+      real plclup(len),plcllo(len),plclfeed(len)
+      real posit(len)
+      logical nocond(len)
+!
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+          gznk(i)=gz(i,nk(i))
+  220    continue
+!
+!-------------------------------------------------------------------
+! --- Adjust feeding layer thickness so that lifting up to the top of
+! --- the feeding layer does not induce condensation (i.e. so that
+! --- plcl < p2feed).
+! --- Method : iterative secant method.
+!-------------------------------------------------------------------
+!
+c 1- First bracketing of the solution : ph(nk+1), p2feed
+c
+c 1.a- LCL associated to p2feed
+      do i = 1,len
+        pup(i) = p2feed(i)
+      enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,pup,p,ph
+     i              ,t,q,u,v,wght
+     o              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclup)
+c 1.b- LCL associated to ph(nk+1)
+      do i = 1,len
+        plo(i) = ph(i,nk(i)+1)
+      enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,plo,p,ph
+     i              ,t,q,u,v,wght
+     o              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plcllo)
+c 2- Iterations
+      niter = 5
+      do iter = 1,niter
+        do i = 1,len
+          plcllo(i) = min(plo(i),plcllo(i))
+          plclup(i) = max(pup(i),plclup(i))
+          nocond(i) = plclup(i).le.pup(i)
+        enddo
+        do i = 1,len
+          if(nocond(i)) then
+             pfeed(i)=pup(i)
+          else
+             pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+
+     :                plo(i)*(plclup(i)-pup(i)))/
+     :            (plo(i)-plcllo(i)+plclup(i)-pup(i))
+          endif
+        enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,pfeed,p,ph
+     i              ,t,q,u,v,wght
+     o              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclfeed)
+        do i = 1,len
+          posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
+          if (plclfeed(i) .eq. pfeed(i)) posit(i) = 1.
+c- posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
+c-               => pup=pfeed
+c- posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
+c-               => plo=pfeed
+          pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i)
+          plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i)
+          plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i)
+          plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i)
+        enddo
+      enddo       !  iter
+      do i = 1,len
+        p2feed(i) = pfeed(i)
+        plcl(i) = plclfeed(i)
+      enddo
+!
+      do 175 i=1,len
+         cpnk(i)=cpd*(1.0-qnk(i))+cpv*qnk(i)
+         hnk(i)=gz(i,1)+cpnk(i)*tnk(i)
+ 175  continue
+!
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( tnk(i).lt.250.0    )
+     &       .or.( qnk(i).le.0.0      ) )
+     &   .and.
+     &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+c
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+
+c     print*,'icb dans cv3_feed '
+c     write(*,'(64i2)') icb(2:len-1)
+c     call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
+
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute1(len,nd,t,qs,gz,plcl,p,icb,tnk,qnk,gznk
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c 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
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len
+         ticb(i)=t(i,icb(i)+1)
+         gzicb(i)=gz(i,icb(i)+1)
+         qsicb(i)=qs(i,icb(i)+1)
+        enddo
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp,thnk,
+     o                pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cv3param.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+      real thnk(len)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+c
+c   ***   make sure that column is dry adiabatic between the surface  ***
+c   ***    and cloud base, and that lifted air is positively buoyant  ***
+c   ***                         at cloud base                         ***
+c   ***       if not, return to calling program after resetting       ***
+c   ***                        sig(i) and w0(i)                       ***
+c
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = thnk(i)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cv3param.h"
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd)
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      do 121 j=1,ntra
+ccccc      do 111 k=1,nl+1
+      do 111 k=1,nd
+       nn=0
+      do 101 i=1,len
+      if(iflag1(i).eq.0)then
+       nn=nn+1
+       tra(nn,k,j)=tra1(i,k,j)
+      endif
+ 101  continue
+ 111  continue
+ 121  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,hnk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real hnk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c 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)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+      integer iposit(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+c ori          if(k.ge.(nk(i)+1))then
+c ori            tca=tp(i,k)-t0
+c ori            if(tca.ge.0.0)then
+c ori              elacrit=elcrit
+c ori            else
+c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+c ori            endif
+c ori            elacrit=max(elacrit,0.0)
+c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+c ori            ep(i,k)=max(ep(i,k),0.0 )
+c ori            ep(i,k)=min(ep(i,k),1.0 )
+c ori            sigp(i,k)=sigs
+c ori          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c=====================================================================
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k)
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+c       buoy(icb(i),k)=buoybase(i)
+      buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+       iposit(i) = nl
+ 510  continue
+
+c
+c--    iposit(i) = first level, above icb, with positive buoyancy
+      do k = 1,nl-1
+       do i = 1,ncum
+        if (k .ge. icb(i) .and. buoy(i,k) .gt. 0.) then
+          iposit(i) = min(iposit(i),k)
+        endif
+       enddo
+      enddo
+
+      do i = 1,ncum
+       if (iposit(i) .eq. nl) then
+         iposit(i) = icb(i)
+       endif
+      enddo
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.iposit(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do k = 1,nd
+      do i=1,ncum
+         hp(i,k)=h(i,k)
+      enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end
+
+      SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m,iflag)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+      integer iflag(nloc)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+      real cbmflast(nloc)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb
+c -------------------------------------------------------
+
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=amax1(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),
+c -- vertical velocity (w), fractional area covered by
+c -- undilute updraft (sig), and updraft mass flux (m)
+c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+c
+cccc 3. Compute final cloud base mass flux and set iflag to 3 if
+cccc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+cccc    the final mass flux (cbmflast) is greater than the target mass flux
+cccc    (cbmf) ??).
+ccc
+cc      do i = 1,ncum
+cc       cbmflast(i) = 0.
+cc      enddo
+ccc
+cc      do k= 1,nl
+cc       do i = 1,ncum
+cc        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
+cc         cbmflast(i) = cbmflast(i)+M(i,k)
+cc        ENDIF
+cc       enddo
+cc      enddo
+ccc
+cc      do i = 1,ncum
+cc       IF (cbmflast(i) .lt. 1.e-6) THEN
+cc         iflag(i) = 3
+cc       ENDIF
+cc      enddo
+ccc
+cc      do k= 1,nl
+cc       do i = 1,ncum
+cc        IF (iflag(i) .ge. 3) THEN
+cc         M(i,k) = 0.
+cc         sig(i,k) = 0.
+cc         w0(i,k) = 0.
+cc        ENDIF
+cc       enddo
+cc      enddo
+ccc
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=amax1(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv3_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,unk,vnk,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c 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 tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c 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)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+cym            ment(i,k,j)=0.0
+cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+      do k=1,ntra
+       do j=1,nd  ! instead nlp
+        do i=1,nd ! instead nlp
+         do il=1,ncum
+            traent(il,i,j,k)=tra(il,j,k)
+         enddo
+        enddo
+       enddo
+      enddo
+      zm(:,:)=0.
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*unk(il)
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*vnk(il)
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+       do k=1,ntra
+        do j=minorig,nl
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+          endif
+         enddo
+        enddo
+       enddo
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+      uent(il,i,i)=unk(il)
+      vent(il,i,i)=vnk(il)
+      elij(il,i,i)=clw(il,i)
+cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+
+      do j=1,ntra
+       do i=minorig+1,nl
+        do il=1,ncum
+         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+          traent(il,i,i,j)=tra(il,nk(il),j)
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=qnk(il)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=unk(il)
+        vent(il,i,i)=vnk(il)
+        elij(il,i,i)=clw(il,i)
+cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+      do j=1,ntra
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+         traent(il,i,i,j)=tra(il,nk(il),j)
+        endif
+       enddo
+      enddo
+789   continue
+c      
+c MAF: renormalisation de MENT
+      call zilch(zm,nloc*na)
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+      SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb,iflag
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl,coef_clos
+     o              ,mp,rp,up,vp,trap,wt,water,evap,b,sigd)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd),gz(nloc,na)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real th(nloc,na),tv(nloc,na),lv(nloc,na),cpn(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+      real coef_clos(nloc)
+c
+c input/output
+      integer iflag(nloc)
+c
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na), sigd(nloc)
+
+c local variables
+      integer i,j,k,il,num1,ndp1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real h(nloc,na),hm(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+        do k=1,ntra
+         do i=1,nd
+          do il=1,ncum
+           trap(il,i,k)=tra(il,i,k)
+          enddo
+         enddo
+        enddo
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+
+c   ***  Set the fractionnal area sigd of precipitating downdraughts
+        do il = 1,ncum
+          sigd(il) = sigdz*coef_clos(il)
+        enddo
+
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+
+c
+c    ***                    begin downdraft loop                    ***
+c
+
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd(il)*wt(il,i))
+c
+cjyg1
+ccc        sigt=1.0
+ccc        if(i.ge.icb)sigt=sigp(i)
+c prise en compte de la variation progressive de sigt dans
+c les couches icb et icb-1:
+c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+c 	pour plcl>ph(i),   pr1=1 & pr2=0
+c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+c    sur le nuage, et pr2 est la proportion sous la base du
+c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+cjyg----
+c       b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+c       c6 = water(il,i+1) + wdtrain(il)*bfac
+c        revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+c        evap(il,i)=sigt*afac*revap
+c        water(il,i)=revap*revap
+cc        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il) ',
+cc     $            i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
+cc---end jyg---
+c
+c--------retour à la formulation originale d'Emanuel.
+      b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :    -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)
+     :            +(wdtrain(il)+sigd(il)*wt(il,i)*water(il,i+1))
+     :                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*50.)
+      end if
+ccc
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd(il)*tevap
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd(il)*tevap
+     :         *(p(il,i-1)-p(il,i))/delth
+      endif
+c
+c    ***           if hydrostatic assumption fails,             ***
+c    ***   solve cubic difference equation for downdraft theta  ***
+c    ***  and mass flux from two simultaneous differential eqns ***
+c
+      amfac=sigd(il)*sigd(il)*70.0*ph(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd(il)*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,i))*xf*tevap
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante:
+C il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1).
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd(il)*0.1)
+     3 -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)
+     : *sigd(il)*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd(il)*0.1)
+     3 -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)
+     : *sigd(il)*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+c
+cc      if(p(il,i).gt.p(il,icb(il)))then
+cc       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+cc      endif
+      if(ph(il,i) .gt. 0.9*plcl(il)) then
+       mp(il,i) = mp(il,i)*(ph(il,1)-ph(il,i))/
+     $                     (ph(il,1)-0.9*plcl(il))
+      endif
+
+360   continue
+      endif ! i.eq.1
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+      do j=1,ntra
+      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+       do j=1,ntra
+       trap(il,i,j)=trap(il,i+1,j)
+       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end
+
+      SUBROUTINE cv3_yield(nloc,ncum,nd,na,ntra
+     :                    ,icb,inb,delt
+     :                    ,t,rr,t_wake,rr_wake,u,v,tra
+     :                    ,gz,p,ph,h,hp,lv,cpn,th
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b,sigd
+     :                    ,ment,qent,hent,iflag_mix,uent,vent
+     :                    ,nent,elij,traent,sig
+     :                    ,tv,tvp,wghti
+     :                    ,iflag,precip,Vprecip,ft,fr,fu,fv,ftra
+     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+     :                    ,tls,tps,qcondc,wd
+     :                    ,ftd,fqd)
+      
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+c inputs:
+c      print*,'cv3_yield apres include'
+      integer iflag_mix
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real t_wake(nloc,nd), rr_wake(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na), sigd(nloc)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+      real hent(nloc,na,na)
+      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd), wghti(nloc,nd)
+c      print*,'cv3_yield declarations 1'
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftd(nloc,nd), fqd(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mip(nloc,nd)
+      real Vprecip(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+      real cbmf(nloc)
+c      print*,'cv3_yield declarations 2'
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real awat(nloc)
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+c      print*,'cv3_yield declarations 3'
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+c      print*,'cv3_yield initialisation delt', delt
+cprecip,Vprecip,ft,fr,fu,fv,ftra
+c     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+c     :                    ,tls,tps,qcondc,wd
+c     :                    ,ftd,fqd  )
+      do il=1,ncum
+       precip(il)=0.0
+c       Vprecip(il,nd+1)=0.0
+       wd(il)=0.0     ! gust
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         Vprecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         upwd(il,i)=0.0
+         dnwd(il,i)=0.0
+         dnwd0(il,i)=0.0
+         mip(il,i)=0.0
+         ftd(il,i)=0.0
+         fqd(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+c       print*,'cv3_yield initialisation 2'
+      do j=1,ntra
+       do i=1,nd
+        do il=1,ncum
+          ftra(il,i,j)=0.0
+        enddo
+       enddo
+      enddo
+c       print*,'cv3_yield initialisation 3'
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum
+       if(ep(il,inb(il)).ge.0.0001 .and. iflag(il) .le. 1)then
+        if (cvflag_grav) then
+           precip(il)=wt(il,1)*sigd(il)*water(il,1)*86400.*1000.
+     :               /(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd(il)*water(il,1)*8640.
+        endif
+       endif
+      enddo
+c      print*,'cv3_yield apres calcul precip'
+
+C
+C   ===  calculate vertical profile of  precipitation in kg/m2/s  ===
+C
+      do i = 1,nl
+      do il=1,ncum
+       if(ep(il,inb(il)).ge.0.0001 .and. i.le.inb(il)
+     :    .and. iflag(il) .le. 1)then
+        if (cvflag_grav) then
+           VPrecip(il,i) = wt(il,i)*sigd(il)*water(il,i)/grav
+        else
+           VPrecip(il,i) = wt(il,i)*sigd(il)*water(il,i)/10.
+        endif
+       endif
+      enddo
+      enddo
+C
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd(il)*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       cbmf(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.ge.icb(il)) then
+         cbmf(il)=cbmf(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+c      print*,'cv3_yield avant ft'
+c AM is the part of cbmf taken from the first level
+      do il=1,ncum
+        am(il)=cbmf(il)*wghti(il,1)
+      enddo
+c
+      do il=1,ncum
+        if (iflag(il) .le. 1) then
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+cjyg  Correction pour conserver l'eau
+ccc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2)) !precip
+       ft(il,1)=-lvcp(il,1)*sigd(il)*evap(il,1)                  !precip
+
+      if (cvflag_grav) then
+        ft(il,1)=ft(il,1)-0.009*grav*sigd(il)*mp(il,2)
+     :                              *t_wake(il,1)*b(il,1)*work(il)
+      else
+        ft(il,1)=ft(il,1)-0.09*sigd(il)*mp(il,2)
+     :                              *t_wake(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd(il)*wt(il,1)*(cl-cpd)*water(il,2)
+     :     *(t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il,1)
+
+      ftd(il,1) = ft(il,1)                        ! fin precip
+
+      if (cvflag_grav) then                  !sature
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=ft(il,1)+0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=ft(il,1)+0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+      endif  ! iflag
+      enddo
+
+
+       do j=2,nl
+      IF (iflag_mix .gt. 0) then
+        do il=1,ncum
+c FH WARNING a modifier :
+      cpinv=0.
+c     cpinv=1.0/cpn(il,1)
+         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+         if (cvflag_grav) then
+          ft(il,1)=ft(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(hent(il,j,1)-h(il,1)
+     :       +t(il,1)*(cpv-cpd)*(rr(il,1)-Qent(il,j,1)))*cpinv
+         else
+          ft(il,1)=ft(il,1)
+     :       +0.1*work(il)*ment(il,j,1)*(hent(il,j,1)-h(il,1)
+     :       +t(il,1)*(cpv-cpd)*(rr(il,1)-Qent(il,j,1)))*cpinv
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+       ENDIF
+        enddo
+         ! fin sature
+
+
+      do il=1,ncum
+        if (iflag(il) .le. 1) then
+          if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr_wake(il,1))*work(il)
+     :          +sigd(il)*evap(il,1)
+ccc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
+
+       fqd(il,1)=fr(il,1)     !precip
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)  !sature
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr_wake(il,1))*work(il)
+     :          +sigd(il)*evap(il,1)
+ccc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
+       fqd(il,1)=fr(il,1)  !precip
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+         endif ! cvflag_grav
+       endif  ! iflag
+      enddo ! il
+
+
+      do j=1,ntra
+       do il=1,ncum
+        if (iflag(il) .le. 1) then
+        if (cvflag_grav) then
+         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+        else
+         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+        endif
+        endif  ! iflag
+       enddo
+      enddo
+
+       do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il) .and. iflag(il) .le. 1) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))  ! fin sature
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+      do k=1,ntra
+       do j=2,nl
+        do il=1,ncum
+         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+
+          if (cvflag_grav) then
+           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+     :                *(traent(il,j,1,k)-tra(il,1,k))
+          else
+           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+     :                *(traent(il,j,1,k)-tra(il,1,k))
+          endif
+
+         endif
+        enddo
+       enddo
+      enddo
+c      print*,'cv3_yield apres ft'
+c
+c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il) .and. iflag(il) .le. 1)num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=1,nl+1
+       do 441 il=1,ncum
+        if(i.ge.icb(il)) then
+          if(k.ge.i+1.and. k.le.(inb(il)+1)) then
+            amp1(il)=amp1(il)+m(il,k)
+          endif
+         else
+c AMP1 is the part of cbmf taken from layers I and lower
+          if(k.le.i) then
+           amp1(il)=amp1(il)+cbmf(il)*wghti(il,k)
+          endif
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il) .and. iflag(il) .le. 1) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+       ! precip
+ccc       ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       ft(il,i)= -sigd(il)*lvcp(il,i)*evap(il,i)
+        rat=cpn(il,i-1)*cpinv
+c
+      if (cvflag_grav) then
+       ft(il,i)=ft(il,i)-0.009*grav*sigd(il)
+     :   *(mp(il,i+1)*t_wake(il,i)*b(il,i)
+     :   -mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*sigd(il)*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+       ftd(il,i)=ft(il,i)
+        ! fin precip
+c
+           ! sature
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+
+c
+      IF (iflag_mix .eq. 0) then
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      ENDIF
+c
+      else  ! cvflag_grav
+       ft(il,i)=ft(il,i)-0.09*sigd(il)
+     :   *(mp(il,i+1)*t_wake(il,i)*b(il,i)
+     :   -mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*sigd(il)*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+       ftd(il,i)=ft(il,i)
+        ! fin precip
+c
+           ! sature
+       ft(il,i)=ft(il,i)+0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+
+c
+      IF (iflag_mix .eq. 0) then
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      ENDIF
+      endif ! cvflag_grav
+
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+c jyg: correction permettant de mieux conserver l'eau:
+ccc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+         fr(il,i)=sigd(il)*evap(il,i)
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i))
+     :        -mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+         fqd(il,i)=fr(il,i)    ! precip
+
+         fu(il,i)=0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+ccc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+         fr(il,i)=sigd(il)*evap(il,i)
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i))
+     :             -mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+         fqd(il,i)=fr(il,i)    ! precip
+
+         fu(il,i)=0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+
+      if (cvflag_grav) then
+       fr(il,i)=fr(il,i)+0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=fr(il,i)+0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+      do k=1,ntra
+       do il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+         if (cvflag_grav) then
+           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+         else
+           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+         endif
+        endif
+       enddo
+      enddo
+
+      do 480 k=1,i-1
+c
+       do il = 1,ncum
+        awat(il)=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+        awat(il)=amax1(awat(il),0.0)
+       enddo
+c
+      IF (iflag_mix .ne. 0) then
+       do il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      ft(il,i)=ft(il,i)
+     :       +0.01*grav*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-Qent(il,k,i)))*cpinv
+
+c
+c
+       else
+      ft(il,i)=ft(il,i)
+     :       +0.1*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-Qent(il,k,i)))*cpinv
+       endif  !cvflag_grav
+       endif  ! i
+       enddo
+      ENDIF
+c
+       do 1370 il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat(il)-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat(il)-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat(il)) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+      do j=1,ntra
+       do k=1,i-1
+        do il=1,ncum
+         if (i.le.inb(il) .and. iflag(il) .le. 1) then
+          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+          cpinv=1.0/cpn(il,i)
+          if (cvflag_grav) then
+           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+     :        *(traent(il,k,i,j)-tra(il,i,j))
+          else
+           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+     :        *(traent(il,k,i,j)-tra(il,i,j))
+          endif
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 490 k=i,nl+1
+c
+      IF (iflag_mix .ne. 0) then
+       do il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)
+     $               .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      ft(il,i)=ft(il,i)
+     :       +0.01*grav*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)-Qent(il,k,i)))*cpinv
+c
+c
+       else
+      ft(il,i)=ft(il,i)
+     :       +0.1*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)-Qent(il,k,i)))*cpinv
+       endif  !cvflag_grav
+       endif  ! i
+       enddo
+      ENDIF
+c
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)
+     $               .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav
+        endif ! i and k
+1380   continue
+490   continue
+
+      do j=1,ntra
+       do k=i,nl+1
+        do il=1,ncum
+         if (i.le.inb(il) .and. k.le.inb(il)
+     $                .and. iflag(il) .le. 1) then
+          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+          cpinv=1.0/cpn(il,i)
+          if (cvflag_grav) then
+           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+     :         *(traent(il,k,i,j)-tra(il,i,j))
+          else
+           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+     :             *(traent(il,k,i,j)-tra(il,i,j))
+          endif
+         endif ! i and k
+        enddo
+       enddo
+      enddo
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum
+        if (k.le.inb(il) .and. i.le.inb(il)
+     $               .and. iflag(il) .le. 1) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0
+     $                 .and. iflag(il) .le. 1) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0
+     $                   .and. iflag(il) .le. 1) then     ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+      do j=1,ntra
+       do il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+         else
+          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+         endif
+        endif ! i
+       enddo
+      enddo
+
+
+500   continue
+
+
+c   ***   move the detrainment at level inb down to level inb-1   ***
+c   ***        in such a way as to preserve the vertically        ***
+c   ***          integrated enthalpy and water tendencies         ***
+c
+      do 503 il=1,ncum
+      IF (iflag(il) .le. 1) THEN
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))
+     : +t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+      ENDIF    !iflag
+503   continue
+
+      do j=1,ntra
+       do il=1,ncum
+        IF (iflag(il) .le. 1) THEN
+        ex=0.1*ment(il,inb(il),inb(il))
+     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+        ENDIF    !iflag
+       enddo
+      enddo
+
+c
+c   ***    homogenize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1) .and. iflag(il) .le. 1) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1) .and. iflag(il) .le. 1) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+         if(i.ge.icb(il)) then
+          if(k.ge.i.and. k.le.(inb(il))) then
+            upwd(il,i)=upwd(il,i)+m(il,k)
+          endif
+         else
+          if(k.lt.i) then
+            upwd(il,i)=upwd(il,i)+cbmf(il)*wghti(il,k)
+          endif
+        endif
+cc        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
+        end do
+       end do
+      end do
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+cc         print *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mip
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mip(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mip(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        icb represente de niveau ou se trouve la
+c        base du nuage , et inb le top du nuage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 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)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)
+     $                     .and. iflag(il) .le. 1) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il)
+     :      .and. iflag(il) .le. 1 ) then                   ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0
+     :       .and. iflag(il) .le. 1 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0 .and. iflag(il) .le. 1)        ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+cIM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)                          ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo
+c        print*,'cv3_yield fin'        
+                                              ! cld
+        return
+        end
+
+
+      SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,iflag1
+     :         ,precip1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :                               )
+      implicit none
+
+#include "cv3param.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+        do 2100 j=1,ntra
+c oct3         do 2110 k=1,nl
+         do 2110 k=1,nd ! oct3
+          do 2120 i=1,ncum
+            ftra1(idcum(i),k,j)=ftra(i,k,j)
+ 2120     continue
+ 2110    continue
+ 2100   continue
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3_vertmix.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3_vertmix.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3_vertmix.F	(revision 984)
@@ -0,0 +1,179 @@
+      SUBROUTINE cv3_vertmix(len,nd,iflag,plim1,plim2,p,ph,t,q,u,v
+     :                     ,w,wi,nk,tmix,thmix,qmix,qsmix
+     :                     ,umix,vmix,plcl)
+***************************************************************
+*                                                             *
+* CV3_VERTMIX   Brassage adiabatique d'une couche d'epaisseur *
+*               arbitraire.                                   *
+*                                                             *
+* written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
+* modified by :  Filiberti M-A 06/2005 vectorisation          *
+***************************************************************
+*
+       implicit none
+C==============================================================
+C
+C vertmix : determine theta et r du melange obtenu en brassant
+C adiabatiquement entre plim1 et plim2, avec une ponderation w.
+C
+C===============================================================
+
+#include "cvthermo.h"
+#include "YOETHF.h"
+#include "YOMCST.h"
+#include "FCTTRE.h"
+c input :
+      integer nd,len
+      integer nk(len),iflag(len)
+      real t(len,nd),q(len,nd),w(nd)
+      real u(len,nd),v(len,nd)
+      real p(len,nd),ph(len,nd+1)
+      real plim1(len),plim2(len)
+c output :
+      real tmix(len),thmix(len),qmix(len),wi(len,nd)
+      real umix(len),vmix(len)
+      real qsmix(len)
+      real plcl(len)
+c internal variables :
+      integer j1(len),j2(len),niflag7
+      real A,B
+      real ahm(len),dpw(len),coef(len)
+      real p1(len,nd),p2(len,nd)
+      real rdcp(len),a2(len),b2(len),pnk(len)
+      real rh(len),chi(len)
+      real cpn
+      real x,y,p0,p0m1,zdelta,zcor
+
+      integer i,j
+
+      do j = 1,nd
+        do i=1,len
+          if (plim1(i).le.ph(i,j)) j1(i) = j
+          if (plim2(i).ge.ph(i,j+1).and.plim2(i).lt.ph(i,j)) j2(i) = j
+        enddo
+      enddo
+c
+      do j=1,nd
+        do i = 1,len
+          wi(i,j) = 0.
+        enddo
+      enddo
+      do i = 1,len
+       ahm(i)=0.
+       qmix(i)=0.
+       umix(i)=0.
+       vmix(i)=0.
+       dpw(i) =0.
+       a2(i)=0.0
+       b2(i) = 0.
+       pnk(i) = p(i,nk(i))
+      enddo
+c
+      p0 = 1000.
+      p0m1 = 1./p0
+c
+      do i=1,len
+        coef(i) = 1./(plim1(i)-plim2(i))
+      end do
+c
+      do  j=1,nd
+        do i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+            p1(i,j) = min(ph(i,j),plim1(i))
+            p2(i,j) = max(ph(i,j+1),plim2(i))
+cCRtest:couplage thermiques: deja normalise
+c             wi(i,j) = w(j)
+c             print*,'wi',wi(i,j)
+            wi(i,j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)
+            dpw(i) = dpw(i)+wi(i,j)
+          endif
+        end do
+      end do
+cCR:print
+c      do i=1,len
+c         print*,'plim',plim1(i),plim2(i)
+c      enddo 
+      do  j=1,nd
+        do i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+            wi(i,j)=wi(i,j)/dpw(i)
+            ahm(i)=ahm(i)+(cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i,j)*wi(i,j)
+            qmix(i)=qmix(i)+q(i,j)*wi(i,j)
+            umix(i)=umix(i)+u(i,j)*wi(i,j)
+            vmix(i)=vmix(i)+v(i,j)*wi(i,j)
+          endif
+        end do
+      end do
+c
+      do i=1,len
+         rdcp(i)=(rrd*(1.-qmix(i))+qmix(i)*rrv)/
+     :            (cpd*(1.-qmix(i))+qmix(i)*cpv)
+      end do
+c
+
+c
+      do 20 j=1,nd
+        do 18 i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+cc            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
+            y=(.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
+cc            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
+            b2(i)=b2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i,j)
+          endif
+   18  continue
+   20  continue
+c
+       do i=1,len
+         tmix(i) = ahm(i)/b2(i)
+         thmix(i) =tmix(i)*(p0/pnk(i))**rdcp(i)
+c         print*,'thmix ahm',ahm(i),b2(i)
+c         print*,'thmix t',tmix(i),p0 
+c         print*,'thmix p',pnk(i),rdcp(i)
+c         print*,'thmix',thmix(i)
+cc         thmix(i) = ahm(i)/a2(i)
+cc         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
+         zdelta=max(0.,sign(1.,rtt-tmix(i)))
+         qsmix(i)= r2es*FOEEW(tmix(i),zdelta)/(pnk(i)*100.)
+         qsmix(i)=min(0.5,qsmix(i))
+         zcor=1./(1.-retv*qsmix(i))
+         qsmix(i)=qsmix(i)*zcor
+       end do
+c
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+
+       niflag7=0
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+c
+        rh(i)=qmix(i)/qsmix(i)
+        chi(i)=tmix(i)/(A-B*rh(i)-tmix(i)) ! convect3
+c   ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
+c  MASQUE UN PB POTENTIEL
+        chi(i)=max(chi(i),0.)
+        rh(i)=max(rh(i),0.)
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+
+        else
+
+          niflag7=niflag7+1
+          plcl(i)=plim2(i)
+c
+        endif ! iflag=7
+
+c      print*,'NIFLAG7  =',niflag7
+
+ 260   continue
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3a_compress.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3a_compress.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3a_compress.F	(revision 984)
@@ -0,0 +1,158 @@
+      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,u1,v1,gz1,th1,th1_wake
+     :    ,tra1
+     :    ,h1     ,lv1     ,cpn1   ,p1,ph1,tv1    ,tp1,tvp1,clw1
+     :    ,h1_wake,lv1_wake,cpn1_wake     ,tv1_wake
+     :    ,sig1,w01,ptop21
+     :    ,Ale1,Alp1
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,hnk,unk,vnk
+     o    ,wghti,pbase,buoybase
+     o    ,t,q,qs,t_wake,q_wake,qs_wake,u,v,gz,th,th_wake
+     o    ,tra
+     o    ,h     ,lv     ,cpn    ,p,ph,tv    ,tp,tvp,clw
+     o    ,h_wake,lv_wake,cpn_wake    ,tv_wake
+     o    ,sig,w0,ptop2
+     o    ,Ale,Alp  )
+***************************************************************
+*                                                             *
+* CV3A_COMPRESS                                               *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+* modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
+***************************************************************
+*
+      implicit none
+
+#include "cv3param.h"
+
+c 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 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),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)
+      real sig1(len,nd), w01(len,nd), ptop21(len)
+      real Ale1(len),Alp1(len)
+
+c outputs:
+c 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 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),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)
+      real sig(len,nd), w0(len,nd), ptop2(len)
+      real Ale(len),Alp(len)
+
+c local variables:
+      integer i,k,nn,j
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        wghti(nn,k)=wghti1(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        t_wake(nn,k)=t1_wake(i,k)
+        q_wake(nn,k)=q1_wake(i,k)
+        qs_wake(nn,k)=qs1_wake(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        th(nn,k)=th1(i,k)
+        th_wake(nn,k)=th1_wake(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        h_wake(nn,k)=h1_wake(i,k)
+        lv_wake(nn,k)=lv1_wake(i,k)
+        cpn_wake(nn,k)=cpn1_wake(i,k)
+        tv_wake(nn,k)=tv1_wake(i,k)
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      do 121 j=1,ntra
+ccccc      do 111 k=1,nl+1
+      do 111 k=1,nd
+       nn=0
+      do 101 i=1,len
+      if(iflag1(i).eq.0)then
+       nn=nn+1
+       tra(nn,k,j)=tra1(i,k,j)
+      endif
+ 101  continue
+ 111  continue
+ 121  continue
+
+      if (nn.ne.ncum) then
+         print*,'WARNING nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      iflag(nn)=iflag1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      hnk(nn)=hnk1(i)
+      unk(nn)=unk1(i)
+      vnk(nn)=vnk1(i)
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      ptop2(nn)=ptop2(i)
+      ale(nn) = ale1(i)
+      alp(nn) = alp1(i)
+      endif
+ 150  continue
+
+      if (nn.ne.ncum) then
+         print*,'WARNING nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3a_uncompress.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3a_uncompress.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3a_uncompress.F	(revision 984)
@@ -0,0 +1,132 @@
+      SUBROUTINE cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag,kbas,ktop
+     :         ,precip,sig,w0,ptop2
+     :         ,ft,fq,fu,fv,ftra
+     :         ,Ma,mip,Vprecip,upwd,dnwd,dnwd0
+     :         ,qcondc,wd,cape,cin
+     :         ,tvp
+     :         ,ftd,fqd
+     :         ,Plim1,Plim2,asupmax,supmax0
+     :         ,asupmaxmin
+     o         ,iflag1,kbas1,ktop1
+     :         ,precip1,sig1,w01,ptop21
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01
+     :         ,qcondc1,wd1,cape1,cin1
+     :         ,tvp1
+     :         ,ftd1,fqd1
+     :         ,Plim11,Plim21,asupmax1,supmax01
+     :         ,asupmaxmin1     )
+***************************************************************
+*                                                             *
+* CV3A_UNCOMPRESS                                             *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+* modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.36.17    *
+***************************************************************
+*
+      implicit none
+
+#include "cv3param.h"
+
+c inputs:
+      integer nloc, len, ncum, nd, ntra
+      integer idcum(nloc)
+      integer iflag(nloc),kbas(nloc),ktop(nloc)
+      real precip(nloc)
+      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 Ma(nloc,nd),mip(nloc,nd),Vprecip(nloc,nd)
+      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)
+
+c outputs:
+      integer iflag1(len),kbas1(len),ktop1(len)
+      real precip1(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 Ma1(len,nd),mip1(len,nd),Vprecip1(len,nd)
+      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)
+c
+c local variables:
+      integer i,k,j,k1,k2
+
+        do 2000 i=1,ncum
+         ptop21(idcum(i))=ptop2(i)
+         precip1(idcum(i))=precip(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)
+ 2000   continue
+
+        do 2020 k=1,nd
+          do 2010 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)
+ 2010     continue
+ 2020   continue
+
+        do 2040 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2040    continue
+
+
+        do 2100 j=1,ntra
+c oct3         do 2110 k=1,nl
+         do 2110 k=1,nd ! oct3
+          do 2120 i=1,ncum
+            ftra1(idcum(i),k,j)=ftra(i,k,j)
+ 2120     continue
+ 2110    continue
+ 2100   continue
+c
+c        do 2220 k2=1,nd
+c         do 2210 k1=1,nd
+c          do 2200 i=1,ncum
+c            ment1(idcum(i),k1,k2) = ment(i,k1,k2)
+c            sij1(idcum(i),k1,k2) = sij(i,k1,k2)
+c2200      enddo
+c2210     enddo
+c2220    enddo
+
+       RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3p1_closure.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3p1_closure.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3p1_closure.F	(revision 984)
@@ -0,0 +1,621 @@
+      SUBROUTINE cv3p1_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,tv,tvp,buoy
+     :                      ,Supmax,ok_inhib,Ale,Alp
+     o                      ,sig,w0,ptop2,cape,cin,m,iflag,coef
+     :                      ,Plim1,Plim2,asupmax,supmax0
+     :                      ,asupmaxmin,cbmf)
+
+*
+***************************************************************
+*                                                             *
+* CV3P1_CLOSURE                                               *
+*                  Ale & Alp Closure of Convect3              *
+*                                                             *
+* written by   :   Kerry Emanuel                              *
+* vectorization:   S. Bony                                    *
+* modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
+*                  Julie Frohwirth,     14/10/2005  17.44.22  *
+***************************************************************
+*
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "YOMCST2.h"
+#include "YOMCST.h"
+#include "conema3.h"
+#include "iniprint.h"
+
+c 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)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd), ptop2(nloc)
+
+c output:
+      real cape(nloc),cin(nloc)
+      real m(nloc,nd)
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,nd),supmax0(nloc)
+      real asupmaxmin(nloc)
+      integer iflag(nloc)
+c
+c local variables:
+      integer il, i, j, k, icbmax, i0(nloc)
+      real deltap, fac, w, amu
+      real rhodp
+      real Pbmxup
+      real dtmin(nloc,nd), sigold(nloc,nd)
+      real coefmix(nloc,nd)
+      real pzero(nloc),ptop2old(nloc)
+      real cina(nloc),cinb(nloc)
+      integer ibeg(nloc)
+      integer nsupmax(nloc)
+      real supcrit,temp(nloc,nd)
+      real P1(nloc),Pmin(nloc)
+      real asupmax0(nloc)
+      logical ok(nloc)
+      real siglim(nloc,nd),wlim(nloc,nd),mlim(nloc,nd)
+      real wb2(nloc)
+      real cbmflim(nloc),cbmf1(nloc),cbmfmax(nloc),cbmf(nloc)
+      real cbmflast(nloc)
+      real coef(nloc)
+      real xp(nloc),xq(nloc),xr(nloc),discr(nloc),b3(nloc),b4(nloc)
+      real theta(nloc),bb(nloc)
+      real term1,term2,term3
+      real alp2(nloc) ! Alp with offset
+      real wb,sigmax
+      data wb /2./, sigmax /0.1/
+c
+c      print *,' -> cv3p1_closure, Ale ',ale(1)
+c
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+c
+c
+      do il = 1,ncum
+       alp2(il) = max(alp(il),1.e-5)
+cIM 
+       alp2(il) = max(alp(il),1.e-12)
+      enddo
+c
+      PBMXUP=50.    ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
+c                     exist (if any)
+
+       if(prt_level.GE.20)
+     . print*,'cv3p1_param nloc ncum nd icb inb nl',nloc,ncum,nd,
+     . icb(nloc),inb(nloc),nl
+      do k=1,nl
+       do il=1,ncum
+        m(il,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb
+c -------------------------------------------------------
+
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 il=1,ncum
+        if ((inb(il).lt.(nl-1)).and.(k.ge.(inb(il)+1)))then
+         sig(il,k)=beta*sig(il,k)
+     :            +2.*alpha*buoy(il,inb(il))*ABS(buoy(il,inb(il)))
+         sig(il,k)=AMAX1(sig(il,k),0.0)
+         w0(il,k)=beta*w0(il,k)
+        endif
+ 110   continue
+ 100  continue
+
+c      if(prt.level.GE.20) print*,'cv3p1_param apres 100'
+c compute icbmax:
+
+      icbmax=2
+      do 200 il=1,ncum
+        icbmax=MAX(icbmax,icb(il))
+ 200  continue
+!     if(prt.level.GE.20) print*,'cv3p1_param apres 200'
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 il=1,ncum
+        if (k.le.icb(il))then
+         sig(il,k)=beta*sig(il,k)-2.*alpha*buoy(il,icb(il))
+     $                                    *buoy(il,icb(il))
+         sig(il,k)=amax1(sig(il,k),0.0)
+         w0(il,k)=beta*w0(il,k)
+        endif
+310    continue
+300    continue
+       if(prt_level.GE.20) print*,'cv3p1_param apres 300'
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+
+      do 400 k=1,nl-1
+       do 410 il=1,ncum
+        if (sig(il,nd).lt.1.5.or.sig(il,nd).gt.12.0)then
+         sig(il,k)=0.0
+         w0(il,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 400'
+c
+c -------------------------------------------------------------
+Cjyg1
+C --  Calculate adiabatic ascent top pressure (ptop)
+c -------------------------------------------------------------
+C
+c
+cc 1. Start at first level where precipitations form
+      do il = 1,ncum
+        Pzero(il) = Plcl(il)-PBcrit
+      enddo
+c
+cc 2. Add offset
+      do il = 1,ncum
+        Pzero(il) = Pzero(il)-PBmxup
+      enddo
+      do il=1,ncum
+         ptop2old(il)=ptop2(il)
+      enddo
+c
+      do il = 1,ncum
+cCR:c est quoi ce 300??
+        P1(il) = Pzero(il)-300.
+      enddo
+
+c    compute asupmax=abs(supmax) up to lnm+1
+
+      DO il=1,ncum
+        ok(il)=.true.
+        nsupmax(il)=inb(il)
+      ENDDO
+
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .and.
+     $       supmax(il,i) .lt. 0 .and. ok(il)) THEN
+           nsupmax(il)=i
+           ok(il)=.false.
+        ENDIF    ! end IF (P(i) ...
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+
+      if(prt_level.GE.20) print*,'cv3p1_param apres 2.'
+      DO i = 1,nl
+        DO il = 1,ncum
+        asupmax(il,i)=abs(supmax(il,i))
+        ENDDO
+      ENDDO
+
+c
+        DO il = 1,ncum
+        asupmaxmin(il)=10.
+        Pmin(il)=100.
+!IM ??
+        asupmax0(il)=0.
+        ENDDO
+
+cc 3.  Compute in which level is Pzero
+
+cIM bug      i0 = 18 
+       DO il = 1,ncum
+        i0(il) = nl
+       ENDDO
+
+       DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+           IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+            IF (Pzero(il) .GT. P(il,i) .AND.
+     $           Pzero(il) .LT. P(il,i-1)) THEN
+             i0(il) = i
+            ENDIF
+           ENDIF
+          ENDIF
+        ENDDO
+       ENDDO
+       if(prt_level.GE.20) print*,'cv3p1_param apres 3.'
+
+cc 4.  Compute asupmax at Pzero
+
+       DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+           IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+             asupmax0(il) = 
+     $             ((Pzero(il)-P(il,i0(il)-1))*asupmax(il,i0(il))
+     $             -(Pzero(il)-P(il,i0(il)))*asupmax(il,i0(il)-1))
+     $             /(P(il,i0(il))-P(il,i0(il)-1))
+           ENDIF
+         ENDIF
+        ENDDO
+       ENDDO
+
+
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (P(il,i) .EQ. Pzero(il)) THEN
+           asupmax(i,il) = asupmax0(il)
+         ENDIF
+        ENDDO
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres 4.'
+
+cc 5. Compute asupmaxmin, minimum of asupmax
+
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+          IF (asupmax(il,i) .LT. asupmaxmin(il)) THEN
+            asupmaxmin(il)=asupmax(il,i)
+            Pmin(il)=P(il,i)
+          ENDIF
+        ENDIF
+        ENDIF
+        ENDDO
+      ENDDO
+
+      DO il = 1,ncum
+!IM
+        if(prt_level.GE.20) THEN
+         print*,'cv3p1_closure il asupmax0 asupmaxmin',il,asupmax0(il),
+     $ asupmaxmin(il) ,Pzero(il),Pmin(il)
+        endif
+          IF (asupmax0(il) .LT. asupmaxmin(il)) THEN
+             asupmaxmin(il) = asupmax0(il)
+             Pmin(il) = Pzero(il)
+          ENDIF
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres 5.' 
+
+c
+c   Compute Supmax at Pzero
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il)) THEN
+         Supmax0(il) = ((P(il,i  )-Pzero(il))*aSupmax(il,i-1)
+     $             -(P(il,i-1)-Pzero(il))*aSupmax(il,i  ))
+     $             /(P(il,i)-P(il,i-1))
+         GO TO 425
+        ENDIF    ! end IF (P(i) ...
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+
+425   continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 425.'
+
+cc 6. Calculate ptop2
+c
+      DO il = 1,ncum
+        IF (asupmaxmin(il) .LT. Supcrit1) THEN
+          Ptop2(il) = Pmin(il)
+        ENDIF
+
+        IF (asupmaxmin(il) .GT. Supcrit1
+     $ .AND. asupmaxmin(il) .LT. Supcrit2) THEN
+          Ptop2(il) = Ptop2old(il)
+        ENDIF
+
+        IF (asupmaxmin(il) .GT. Supcrit2) THEN
+            Ptop2(il) =  Ph(il,inb(il))
+        ENDIF
+      ENDDO
+c
+      if(prt_level.GE.20) print*,'cv3p1_param apres 6.'
+
+cc 7. Compute multiplying factor for adiabatic updraught mass flux
+c
+c
+      IF (ok_inhib) THEN
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .le. nl) THEN
+         coefmix(il,i) = (min(ptop2(il),ph(il,i))-ph(il,i))
+     $                  /(ph(il,i+1)-ph(il,i))
+         coefmix(il,i) = min(coefmix(il,i),1.)
+         ENDIF
+        ENDDO
+      ENDDO
+c
+c
+      ELSE   ! when inhibition is not taken into account, coefmix=1
+c
+
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .le. nl) THEN
+         coefmix(il,i) = 1.
+         ENDIF
+        ENDDO
+      ENDDO
+c
+      ENDIF  ! ok_inhib
+      if(prt_level.GE.20) print*,'cv3p1_param apres 7.'
+c -------------------------------------------------------------------
+c -------------------------------------------------------------------
+c
+
+Cjyg2
+C
+c==========================================================================
+C
+c
+c -------------------------------------------------------------
+c -- Calculate convective inhibition (CIN)
+c -------------------------------------------------------------
+
+c      do i=1,nloc
+c      print*,'avant cine p',pbase(i),plcl(i)
+c      enddo
+c     do j=1,nd
+c     do i=1,nloc
+c      print*,'avant cine t',tv(i),tvp(i)
+c     enddo
+c     enddo
+      CALL cv3_cine (nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,tv,tvp
+     :                      ,cina,cinb)
+c
+      DO il = 1,ncum
+        cin(il) = cina(il)+cinb(il)
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres cv3_cine'
+c -------------------------------------------------------------
+c --Update buoyancies to account for Ale
+c -------------------------------------------------------------
+c
+      CALL cv3_buoy (nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,Ale,Cin
+     :                      ,tv,tvp
+     :                      ,buoy )
+      if(prt_level.GE.20) print*,'cv3p1_param apres cv3_buoy'
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),
+c -- vertical velocity (w), fractional area covered by
+c -- undilute updraft (sig), and updraft mass flux (m)
+c -------------------------------------------------------------
+
+      do 500 il=1,ncum
+       cape(il)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do k=1,nl
+       do il=1,ncum
+         dtmin(il,k)=100.0
+       enddo
+      enddo
+
+      do 550 k=1,nl
+       do 560 j=minorig,nl
+        do 570 il=1,ncum
+          if ( (k.ge.(icb(il)+1)).and.(k.le.inb(il)).and.
+     :         (j.ge.icb(il)).and.(j.le.(k-1)) )then
+           dtmin(il,k)=AMIN1(dtmin(il,k),buoy(il,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 il=1,ncum
+
+        if ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) then
+
+         deltap = MIN(pbase(il),ph(il,k-1))-MIN(pbase(il),ph(il,k))
+         cape(il)=cape(il)+rrd*buoy(il,k-1)*deltap/p(il,k-1)
+         cape(il)=AMAX1(0.0,cape(il))
+         sigold(il,k)=sig(il,k)
+
+
+cjyg       Coefficient coefmix limits convection to levels where a sufficient
+c          fraction of mixed draughts are ascending.
+         siglim(il,k)=coefmix(il,k)*alpha1*dtmin(il,k)*ABS(dtmin(il,k))
+         siglim(il,k)=amax1(siglim(il,k),0.0)
+         siglim(il,k)=amin1(siglim(il,k),0.01)
+cc         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
+         fac = 1.
+         wlim(il,k)=fac*SQRT(cape(il))
+         amu=siglim(il,k)*wlim(il,k)
+         rhodp = 0.007*p(il,k)*(ph(il,k)-ph(il,k+1))/tv(il,k)
+         mlim(il,k)=amu*rhodp
+c         print*, 'siglim ', k,siglim(1,k)
+        endif
+
+ 610   continue
+ 600  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 600'
+
+      do 700 il=1,ncum
+!IM beg
+        if(prt_level.GE.20) THEN
+         print*,'cv3p1_closure il icb mlim ph ph+1 ph+2',il,
+     $icb(il),mlim(il,icb(il)+1),ph(il,icb(il)),
+     $ph(il,icb(il)+1),ph(il,icb(il)+2)
+        endif
+
+        if (icb(il)+1.le.inb(il)) then
+!IM end
+       mlim(il,icb(il))=0.5*mlim(il,icb(il)+1)
+     :             *(ph(il,icb(il))-ph(il,icb(il)+1))
+     :             /(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+!IM beg
+        endif !(icb(il.le.inb(il))) then
+!IM end
+ 700  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 700'
+
+cjyg1
+c------------------------------------------------------------------------
+cc     Correct mass fluxes so that power used to overcome CIN does not
+cc     exceed Power Available for Lifting (PAL).
+c------------------------------------------------------------------------
+c
+      do il = 1,ncum
+       cbmflim(il) = 0.
+       cbmf(il) = 0.
+      enddo
+c
+cc 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim)
+c
+      do k= 1,nl
+       do il = 1,ncum
+!IM       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
+         cbmflim(il) = cbmflim(il)+MLIM(il,k)
+        ENDIF
+       enddo
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim'
+
+cc 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
+cc     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
+cc     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud) is
+c--    exceedingly small.
+c
+      DO il = 1,ncum
+        wb2(il) = sqrt(2.*max(Ale(il)+cin(il),0.))
+      ENDDO
+c
+      DO il = 1,ncum
+       cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il))
+       if(cbmf1(il).EQ.0.AND.alp2(il).NE.0.) THEN
+        print*,'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ',il,
+     . alp2(il),alp(il),cin(il)
+        STOP 
+       endif
+       cbmfmax(il) = sigmax*wb2(il)*100.*p(il,icb(il))
+     :              /(rrd*tv(il,icb(il)))
+      ENDDO
+c
+      DO il = 1,ncum
+       IF (cbmflim(il) .gt. 1.e-6) THEN
+cATTENTION TEST CR
+c         if (cbmfmax(il).lt.1.e-12) then
+        cbmf(il) = min(cbmf1(il),cbmfmax(il))
+c         else
+c         cbmf(il) = cbmf1(il)
+c         endif
+c        print*,'cbmf',cbmf1(il),cbmfmax(il)
+       ENDIF
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim_testCR'
+c
+cc 2. Compute coefficient and apply correction
+c
+      do il = 1,ncum
+       coef(il) = (cbmf(il)+1.e-10)/(cbmflim(il)+1.e-10)
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres coef_plantePLUS'
+c
+      DO k = 1,nl
+        do il = 1,ncum
+         IF ( k .ge. icb(il)+1 .AND. k .le. inb(il)) THEN
+         sig(il,k) = beta*sig(il,k)+(1.-beta)*coef(il)*siglim(il,k)
+cc         sig(il,k) = beta*sig(il,k)+siglim(il,k)
+         w0(il,k) = beta*w0(il,k)  +(1.-beta)*wlim(il,k)
+         AMU=SIG(il,k)*W0(il,k)
+cc         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
+         M(il,k)=AMU*0.007*P(il,k)*(PH(il,k)-PH(il,k+1))/TV(il,k)
+         ENDIF
+        enddo
+      ENDDO
+cjyg2
+      DO il = 1,ncum
+       w0(il,icb(il))=0.5*w0(il,icb(il)+1)
+       m(il,icb(il))=0.5*m(il,icb(il)+1)
+     $       *(ph(il,icb(il))-ph(il,icb(il)+1))
+     $       /(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+       sig(il,icb(il))=sig(il,icb(il)+1)
+       sig(il,icb(il)-1)=sig(il,icb(il))
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres w0_sig_M'
+c
+cc 3. Compute final cloud base mass flux and set iflag to 3 if
+cc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+cc    the final mass flux (cbmflast) is greater than the target mass flux
+cc    (cbmf)).
+c
+      do il = 1,ncum
+       cbmflast(il) = 0.
+      enddo
+c
+      do k= 1,nl
+       do il = 1,ncum
+        IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+ !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
+         cbmflast(il) = cbmflast(il)+M(il,k)
+        ENDIF
+       enddo
+      enddo
+c
+      do il = 1,ncum
+       IF (cbmflast(il) .lt. 1.e-6 .and.
+     $     cbmflast(il) .ge. cbmf(il)) THEN
+         iflag(il) = 3
+       ENDIF
+      enddo
+c
+      do k= 1,nl
+       do il = 1,ncum
+        IF (iflag(il) .ge. 3) THEN
+         M(il,k) = 0.
+         sig(il,k) = 0.
+         w0(il,k) = 0.
+        ENDIF
+       enddo
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres iflag'
+c
+cc 4. Introduce a correcting factor for coef, in order to obtain an effective
+cc    sigdz larger in the present case (using cv3p1_closure) than in the old
+cc    closure (using cv3_closure).
+      if (1.eq.0) then
+       do il = 1,ncum 
+cc      coef(il) = 2.*coef(il)
+        coef(il) = 5.*coef(il)
+       enddo
+c version CVS du ..2008
+      else
+       if (iflag_cvl_sigd.eq.0) then
+ctest pour verifier qu on fait la meme chose qu avant: sid constant
+        coef(1:ncum)=1.
+       else
+        coef(1:ncum) = min(2.*coef(1:ncum),5.)
+        coef(1:ncum) = max(2.*coef(1:ncum),0.2)
+       endif
+      endif
+c
+      if(prt_level.GE.20) print*,'cv3p1_param FIN'
+       return
+       end
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3p_mixing.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3p_mixing.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3p_mixing.F	(revision 984)
@@ -0,0 +1,546 @@
+      SUBROUTINE cv3p_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,unk,vnk,hp,tv,tvp,ep,clw,sig
+     :                    ,ment,qent,hent,uent,vent
+     :                   ,sij,elij,supmax,ments,qents,traent)
+***************************************************************
+*                                                             *
+* CV3P_MIXING : compute mixed draught properties and,         *
+*               within a scaling factor, mixed draught        *
+*               mass fluxes.                                  *
+* written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+c
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "YOMCST2.h"
+
+c 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)
+      real h(nloc,na)  !liquid water static energy of environment
+      real hp(nloc,na) !liquid water static energy of air shed from adiab. asc.
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+
+c 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 supmax(nloc,na)     ! Highest mixing fraction of mixed updraughts
+                               ! with the sign of (h-hp)
+      real traent(nloc,nd,nd,ntra)
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real sigij(nloc,nd,nd)
+      real hent(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, delp, delm
+      real Qmixmax(nloc), Rmixmax(nloc), SQmRmax(nloc)
+      real Qmixmin(nloc), Rmixmin(nloc), SQmRmin(nloc)
+      real signhpmh(nloc)
+      real Sx, Scrit2
+      integer Jx
+      real smid(nloc), sjmin(nloc), sjmax(nloc)
+      real Sbef(nloc), Sup(nloc), Smin(nloc)
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real csum(nloc,nd)
+      real awat
+      logical lwork(nloc)
+c
+      REAL amxupcrit, df, ff
+      INTEGER nstep
+C
+c --   Mixing probability distribution functions
+c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *
+     $            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/
+     $           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))
+     1             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+C
+      INTEGER ifrst
+      DATA ifrst/0/
+C
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+c -- Initialize mixing PDF coefficients
+      IF (ifrst .EQ. 0) THEN
+        ifrst = 1
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+c
+      ENDIF
+c
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            hent(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+      do k=1,ntra
+       do j=1,nd  ! instead nlp
+        do i=1,nd ! instead nlp
+         do il=1,ncum
+            traent(il,i,j,k)=tra(il,j,k)
+         enddo
+        enddo
+       enddo
+      enddo
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+              if(sij(il,i,j).gt.0.0)then
+ccc                 ment(il,i,j)=m(il,i)
+                 ment(il,i,j)=1.
+                 elij(il,i,j)=altem
+                 elij(il,i,j)=amax1(0.0,elij(il,i,j))
+                 nent(il,i)=nent(il,i)+1
+              endif
+
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il))
+     :                  .and.(nent(il,i).eq.0)) then
+c@      if(nent(il,i).eq.0)then
+ccc      ment(il,i,i)=m(il,i)
+      ment(il,i,i)=1.
+      qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+      uent(il,i,i)=unk(il)
+      vent(il,i,i)=vnk(il)
+      elij(il,i,i)=clw(il,i)*(1.-ep(il,i))
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+
+      do j=1,ntra
+       do i=minorig+1,nl
+        do il=1,ncum
+         if (i.ge.icb(il) .and. i.le.inb(il)
+     :                    .and. nent(il,i).eq.0) then
+          traent(il,i,i,j)=tra(il,nk(il),j)
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        Signhpmh(il) = sign(1.,hp(il,i)-h(il,i))
+        qp=qnk(il)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=min(anum/denom,1.)
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+c
+cjyg1    Find maximum of SIJ for J>I, if any, and new critical value Scrit2
+c        such that : Sij > Scrit2  => mixed draught will detrain at J<I
+c                    Sij < Scrit2  => mixed draught will detrain at J>I
+c
+       Sx = 0.
+       Jx = 0.
+       Sbef(il) = max(0.,signhpmh(il))
+       DO j = i+1,inb(il)
+         IF (Sbef(il) .LT. Sij(il,i,j)) THEN
+           Sx = max(Sij(il,i,j),Sx)
+           Jx = J
+         ENDIF
+         Sbef(il) = Sij(il,i,j)
+       ENDDO
+c
+       Scrit2 = min(Scrit(il),Sx)*max(0.,-signhpmh(il))
+     :         +Scrit(il)*max(0.,signhpmh(il))
+c
+       Scrit(il) = Scrit2
+c
+cjyg    Correction pour la nouvelle logique; la correction pour ALT
+c       est un peu au hazard
+       if(scrit(il).le.0.0)scrit(il)=0.0
+       if(alt.le.0.0) scrit(il)=1.0
+C
+        smax(il)=0.0
+        asij(il)=0.0
+       Sup(il)=0.     ! upper S-value reached by descending draughts
+       endif
+781   continue
+
+      do 175 j=minorig,nl
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+c -----------------------------------------------
+         IF (j .GT. i) THEN
+c -----------------------------------------------
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il)=min(Sij(il,i,j),Scrit(il))
+           Sjmax(il)=Smid(il)
+           Sjmin(il)=Smid(il)
+           IF (Smid(il) .LT. Smin(il) .AND.
+     1                         Sij(il,i,j+1) .LT. Smid(il)) THEN
+             Smin(il)=Smid(il)
+             Sjmax(il)=min( (Sij(il,i,j+1)+Sij(il,i,j))/2. ,
+     1                  Sij(il,i,j) ,
+     1                  Scrit(il) )
+             Sjmin(il)=max( (Sbef(il)+Sij(il,i,j))/2. ,
+     1                  Sij(il,i,j) )
+             Sjmin(il)=min(Sjmin(il),Scrit(il))
+             Sbef(il) = Sij(il,i,j)
+           ENDIF
+      endif
+      endif
+782   continue
+c -----------------------------------------------
+         ELSE IF (j .EQ. i) THEN
+c -----------------------------------------------
+      do 783 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il) = 1.
+           Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2.,Scrit(il))
+     1                                         *max(0.,-signhpmh(il))
+     1            +min((Sij(il,i,j+1)+Smid(il))/2.,Scrit(il))
+     1                                         *max(0., signhpmh(il))
+           Sjmin(il) = max(Sjmin(il),Sup(il))
+           Sjmax(il) = 1.
+c
+c-           preparation des variables Scrit, Smin et Sbef pour la partie j>i
+           Scrit(il) = min(Sjmin(il),Sjmax(il),Scrit(il))
+
+           Smin(il) = 1.
+           Sbef(il) = max(0.,signhpmh(il))
+           Supmax(il,i) = sign(Scrit(il),-signhpmh(il))
+      endif
+      endif
+783   continue
+c -----------------------------------------------
+         ELSE IF ( j .LT. i) THEN
+c -----------------------------------------------
+      do 784 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il)=max(Sij(il,i,j),Scrit(il))
+           Sjmax(il) = Smid(il)
+           Sjmin(il) = Smid(il)
+           IF (Smid(il) .GT. Smax(il) .AND.
+     1                          Sij(il,i,j+1) .GT. Smid(il)) THEN
+             Smax(il) = Smid(il)
+             Sjmax(il) = max( (Sij(il,i,j+1)+Sij(il,i,j))/2. ,
+     1                                               Sij(il,i,j) )
+             Sjmax(il) = max(Sjmax(il),Scrit(il))
+             Sjmin(il) = min( (Sbef(il)+Sij(il,i,j))/2. ,
+     1                                               Sij(il,i,j) )
+             Sjmin(il) = max(Sjmin(il),Scrit(il))
+             Sbef(il) = Sij(il,i,j)
+           ENDIF
+          IF (abs(Sjmin(il)-Sjmax(il)) .GT. 1.e-10) Sup(il)=
+     1                            max(Sjmin(il),Sjmax(il),Sup(il))
+      endif
+      endif
+784   continue
+c -----------------------------------------------
+         END IF
+c -----------------------------------------------
+c
+c
+      do il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+         Qmixmax(il)=Qmix(Sjmax(il))
+         Qmixmin(il)=Qmix(Sjmin(il))
+         Rmixmax(il)=Rmix(Sjmax(il))
+         Rmixmin(il)=Rmix(Sjmin(il))
+         SQmRmax(il)= Sjmax(il)*Qmix(Sjmax(il))-Rmix(Sjmax(il))
+         SQmRmin(il)= Sjmin(il)*Qmix(Sjmin(il))-Rmix(Sjmin(il))
+c
+         Ment(il,i,j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il,i,j)
+c
+c    Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
+         IF (abs(Qmixmax(il)-Qmixmin(il)) .GT. 1.e-10) THEN
+           Sigij(il,i,j) =
+     :           (SQmRmax(il)-SQmRmin(il))/(Qmixmax(il)-Qmixmin(il))
+         ELSE
+           Sigij(il,i,j) = 0.
+         ENDIF
+c
+c --    Compute Qent, uent, vent according to the true mixing fraction
+        Qent(il,i,j) = (1.-Sigij(il,i,j))*rti
+     :               + Sigij(il,i,j)*rr(il,i)
+        uent(il,i,j) = (1.-Sigij(il,i,j))*unk(il)
+     :               + Sigij(il,i,j)*u(il,i)
+        vent(il,i,j) = (1.-Sigij(il,i,j))*vnk(il)
+     :               + Sigij(il,i,j)*v(il,i)
+c
+c--     Compute liquid water static energy of mixed draughts
+        IF (j .GT. i) THEN
+         awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
+         awat=amax1(awat,0.0)
+        ELSE
+         awat = 0.
+        ENDIF
+        Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
+     :         + Sigij(il,i,j)*H(il,i)
+     :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
+c
+c      print *,'mix : i,j,hent(il,i,j),sigij(il,i,j) ',
+c     :               i,j,hent(il,i,j),sigij(il,i,j)
+c
+c --      ASij is the integral of P(F) over the relevant F interval
+         ASij(il) = ASij(il)
+     1               + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il)
+     1                    -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+c
+      endif
+      endif
+      enddo
+       do k=1,ntra
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :      .and. lwork(il) ) then
+          if(sij(il,i,j).gt.0.0)then
+            traent(il,i,j,k)=sigij(il,i,j)*tra(il,i,k)
+     :            +(1.-sigij(il,i,j))*tra(il,nk(il),k)
+          endif
+          endif
+         enddo
+       enddo
+c
+c --    If I=J (detrainement and entrainement at the same level), then only the
+c --    adiabatic ascent part of the mixture is considered
+        IF (I .EQ. J) THEN
+      do il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+ccc          Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
+          Ment(il,i,i) = abs(Qmixmax(il)*(1.-Sjmax(il))
+     1                    +Rmixmax(il)
+     1                    -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+          Qent(il,i,i) = rti
+          uent(il,i,i) = unk(il)
+          vent(il,i,i) = vnk(il)
+          Hent(il,i,i) = hp(il,i)
+          Elij(il,i,i) = clw(il,i)*(1.-ep(il,i))
+          Sigij(il,i,i) = 0.
+      endif
+      endif
+      enddo
+       do k=1,ntra
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :      .and. lwork(il) ) then
+          if(sij(il,i,j).gt.0.0)then
+            traent(il,i,i,k)=tra(il,nk(il),k)
+          endif
+          endif
+         enddo
+       enddo
+c
+        ENDIF
+c
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.1. ) then
+ccc     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+ccc        ment(il,i,i)=m(il,i)
+        ment(il,i,i)=1.
+        qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=unk(il)
+        vent(il,i,i)=vnk(il)
+        elij(il,i,i)=clw(il,i)*(1.-ep(il,i))
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+      do j=1,ntra
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.1. ) then
+ccc     :     .and. csum(il,i).lt.m(il,i) ) then
+         traent(il,i,i,j)=tra(il,nk(il),j)
+        endif
+       enddo
+      enddo
+c
+789   continue
+c
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv3param.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv3param.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv3param.h	(revision 984)
@@ -0,0 +1,24 @@
+c------------------------------------------------------------
+c Parameters for convectL, iflag_con=3:
+c (includes - microphysical parameters,
+c			- parameters that control the rate of approach
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigdz, spfac
+      real pbcrit, ptcrit
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha, alpha1
+      real delta
+      real betad
+
+      COMMON /cv3param/  noff, minorig, nl, nlp, nlm
+     :                ,  sigdz, spfac
+     :                ,pbcrit, ptcrit
+     :                ,omtrain
+     :                ,dtovsh, dpbase, dttrig
+     :                ,dtcrit, tau, beta, alpha, alpha1, delta, betad
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv_driver.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv_driver.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv_driver.F	(revision 984)
@@ -0,0 +1,707 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con,
+     &                   t1,q1,qs1,u1,v1,tra1,
+     &                   p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,VPrecip1,
+     &                   cbmf1,sig1,w01,
+     &                   icb1,inb1,
+     &                   delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1,
+     &                   da1,phi1,mp1)
+C
+      USE dimphy
+      implicit none
+C
+C.............................START PROLOGUE............................
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      iflag1        Integer        Output       flag for Emanuel conditions
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      VPrecip1      Real           Output       vertical profile of precipitations
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      delt          Real           Input        time step
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux 
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+C
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3) 
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2) 
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg) 
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      integer iflag_con
+      integer ntra
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real precip1(len)
+      real cbmf1(len)
+      real VPrecip1(len,nd+1)
+      real Ma1(len,nd)
+      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 da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+      real da(len,nd),phi(len,nd,nd),mp(len,nd)
+      real tra1(len,nd,ntra)
+      real ftra1(len,nd,ntra)
+
+      real delt
+
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  VPrecip: Vertical profile of convective precipitation (kg/m2/s).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+
+      integer i,k,n,il,j
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer inb1(klon)
+      integer icbs1(klon)
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev)
+      real cpn1(klon,klev)
+      real tv1(klon,klev)
+      real gz1(klon,klev)
+      real hm1(klon,klev)
+      real h1(klon,klev)
+      real tp1(klon,klev)
+      real tvp1(klon,klev)
+      real clw1(klon,klev)
+      real sig1(klon,klev)
+      real w01(klon,klev)
+      real th1(klon,klev)
+c
+      integer ncum
+c
+c (local) compressed fields:
+c
+cym      integer nloc
+cym      parameter (nloc=klon) ! pour l'instant
+#define nloc klon
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real sij(nloc,klev,klev), elij(nloc,klev,klev)
+      real qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+      real b(nloc,klev), ft(nloc,klev), fq(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+
+      nent(:,:)=0
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters 
+c
+c 	includes microphysical parameters and parameters that 
+c  	control the rate of approach to quasi-equilibrium) 
+c 	(common cvparam)
+
+
+      if (iflag_con.eq.30) then
+       CALL cv30_param(nd,delt)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft1(i,k)=0.0
+         fq1(i,k)=0.0
+         fu1(i,k)=0.0
+         fv1(i,k)=0.0
+         tvp1(i,k)=0.0
+         tp1(i,k)=0.0
+         clw1(i,k)=0.0
+cym
+         clw(i,k)=0.0	 
+         gz1(i,k) = 0.
+         VPrecip1(i,k) = 0.
+         Ma1(i,k)=0.0
+         upwd1(i,k)=0.0
+         dnwd1(i,k)=0.0
+         dnwd01(i,k)=0.0
+         qcondc1(i,k)=0.0
+ 10     continue
+ 20   continue
+
+      do 30 j=1,ntra
+       do 31 k=1,nd
+        do 32 i=1,len
+         ftra1(i,k,j)=0.0
+ 32     continue    
+ 31    continue    
+ 30   continue    
+
+      do 60 i=1,len
+        precip1(i)=0.0
+        iflag1(i)=0
+        wd1(i)=0.0
+        cape1(i)=0.0
+        VPrecip1(i,nd+1)=0.0
+ 60   continue
+
+      if (iflag_con.eq.30) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+
+!       print*,'Emanuel version 30 '
+       CALL cv30_prelim(len,nd,ndp1,t1,q1,p1,ph1            ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1           ! nd->na
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part 
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content. 
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1  ! nd->na
+     o                        ,tp1,tvp1,clw1,icbs1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+
+c       print*,'klon, ncum = ',len,ncum
+
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.30) then
+       CALL cv30_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+
+!-------------------------------------------------------------------
+! --- MIXING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                     ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,m,sig
+     o ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_unsat(nloc,ncum,nd,nd,ntra,icb,inb    ! na->nd
+     :               ,t,q,qs,gz,u,v,tra,p,ph
+     :               ,th,tv,lv,cpn,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl
+     o          ,mp,qp,up,vp,trap,wt,water,evap,b)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b
+     :                     ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                     ,tv,tvp
+     o                     ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra
+     o                     ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.30) then
+       CALL cv30_tracer(nloc,len,ncum,nd,nd,
+     :                  ment,sij,da,phi)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+c set iflag1 =42 for non convective points 
+      do  i=1,len
+        iflag1(i)=42
+      end do
+c
+      if (iflag_con.eq.30) then
+       CALL cv30_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag
+     :          ,precip,VPrecip,sig,w0
+     :          ,ft,fq,fu,fv,ftra
+     :          ,inb 
+     :          ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :          ,da,phi,mp
+     o          ,iflag1
+     o          ,precip1,VPrecip1,sig1,w01
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,inb1
+     o          ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 
+     o          ,da1,phi1,mp1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc            
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )           
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_flag
+      implicit none
+
+#include "cvflag.h"
+
+c -- si .TRUE., on rend la gravite plus explicite et eventuellement
+c differente de 10.0 dans convect3: 
+      cvflag_grav = .TRUE.
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_thermo(iflag_con)
+	  implicit none
+
+c-------------------------------------------------------------
+c Set thermodynamical constants for convectL
+c-------------------------------------------------------------
+
+#include "YOMCST.h" 
+#include "cvthermo.h" 
+
+      integer iflag_con
+
+
+c original set from convect:
+      if (iflag_con.eq.4) then
+       cpd=1005.7
+       cpv=1870.0
+       cl=4190.0
+       rrv=461.5
+       rrd=287.04
+       lv0=2.501E6
+       g=9.8
+       t0=273.15
+       grav=g
+      else
+
+c constants consistent with LMDZ:
+       cpd = RCPD
+       cpv = RCPV
+       cl  = RCW
+       rrv = RV
+       rrd = RD
+       lv0 = RLVTT
+       g   = RG     ! not used in convect3
+c ori      t0  = RTT
+       t0  = 273.15 ! convect3 (RTT=273.16)
+c maf       grav= 10.    ! implicitely or explicitely used in convect3
+       grav= g    ! implicitely or explicitely used in convect3
+      endif
+
+      rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?)
+
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      cpvmcl=cl-cpv ! for convect3
+      eps=rrd/rrv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c      ginv=1.0/g
+      ginv=1.0/grav
+      hrd=0.5*rrd
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cv_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cv_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cv_routines.F	(revision 984)
@@ -0,0 +1,1755 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_param(nd)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL
+c (includes microphysical parameters and parameters that 
+c  control the rate of approach to quasi-equilibrium) 
+c------------------------------------------------------------
+
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+#include "cvparam.h"
+      integer nd
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+      noff = 2
+      minorig = 2
+
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      elcrit=0.0011
+      tlcrit=-55.0
+      entp=1.5
+      sigs=0.12
+      sigd=0.05
+      omtrain=50.0
+      omtsnow=5.5
+      coeffr=1.0
+      coeffs=0.8
+      dtmax=0.9
+c
+      cu=0.70
+c
+      betad=10.0
+c
+      damp=0.1
+      alpha=0.2
+c
+      delta=0.01  ! cld
+c
+      return
+      end
+
+      SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+
+c local variables:
+      integer k, i
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+
+      do 110 k=1,nlp
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C================================================================
+
+#include "cvparam.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax
+     :                       ,tp,tvp,clw)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len), icbmax
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd)
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-t0)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+      return
+      end
+
+      SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+#include "cvparam.h"
+
+c inputs:
+       integer len, nd, icb(len)
+       real cbmf(len), tv(len,nd), tvp(len,nd)
+
+c outputs:
+       integer iflag(len) ! also an input
+
+c local variables:
+       integer i
+
+
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+      return
+      end
+
+      SUBROUTINE cv_compress( len,nloc,ncum,nd
+     :   ,iflag1,nk1,icb1
+     :   ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :   ,t1,q1,qs1,u1,v1,gz1
+     :   ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o   ,iflag,nk,icb
+     o   ,cbmf,plcl,tnk,qnk,gznk
+     o   ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o   ,dph          )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len,ncum,nd,nloc
+      integer iflag1(len),nk1(len),icb1(len)
+      real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+
+c outputs:
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real dph(nloc,nd)
+
+c local variables:
+      integer i,k,nn
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      cbmf(nn)=cbmf1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      do 170 k=1,nl
+       do 160 i=1,ncum
+        dph(i,k)=ph(i,k)-ph(i,k+1)
+ 160   continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,dph,h,tv,lv
+     o                       ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd), dph(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+
+c outputs:
+      integer inb(nloc), inb1(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real frac(nloc)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=sigs
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-t0)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-t0)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-t0
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+c initialization:
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+        return
+        end
+c
+      SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb
+     :                     ,tv,tvp,p,ph,dph,plcl,cpn
+     :                     ,iflag,cbmf)
+      implicit none
+
+c inputs:
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc)
+      real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd)
+      real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent...
+      real plcl(nloc), cpn(nloc,nd)
+
+c outputs:
+      integer iflag(nloc)
+      real cbmf(nloc) ! also an input
+
+c local variables:
+      integer i, k, icbmax
+      real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+      real work(nloc)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c-------------------------------------------------------------------
+c Compute icbmax. 
+c-------------------------------------------------------------------
+
+      icbmax=2
+      do 230 i=1,ncum
+       icbmax=max(icbmax,icb(i))
+ 230  continue
+
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX 
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+
+       return
+       end
+
+      SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1
+     :                    ,ph,t,q,qs,u,v,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,cbmf
+     :                    ,m,ment,qent,uent,vent,nent,sij,elij)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+      real cbmf(nloc), qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd)
+      real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd)
+      real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd)
+
+c outputs:
+      integer nent(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real sij(nloc,nd,nd), elij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, ij
+      integer num1, num2
+      real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+      real alt, qp1, smid, sjmin, sjmax, delp, delm
+      real work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+      real bsum(nloc,nd)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          m(i,1)=0.0
+ 360    continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rrv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+       return
+       end
+
+      SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                  ,h,lv,ep,sigp,clw,m,ment,elij
+     :                  ,iflag,mp,qp,up,vp,wt,water,evap)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer inb(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd)
+      real gz(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd)
+
+c outputs:
+      integer iflag(nloc) ! also an input
+      real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+      real water(nloc,nd), evap(nloc,nd), wt(nloc,nd)
+
+c local variables:
+      integer i,j,k,ij,num1
+      integer jtt(nloc)
+      real awat, coeff, qsm, afac, sigt, b6, c6, revap
+      real dhdp, fac, qstm, rat
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c Initializations:
+c
+         do i = 1, ncum
+         do k = 1, nl+1
+          wt(i,k) = omtsnow
+          mp(i,k) = 0.0
+          evap(i,k) = 0.0
+          water(i,k) = 0.0
+         enddo
+         enddo
+
+         do 420 i=1,ncum
+          qp(i,1)=q(i,1)
+          up(i,1)=u(i,1)
+          vp(i,1)=v(i,1)
+ 420     continue
+
+         do 440 k=2,nl+1
+         do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430     continue
+ 440     continue
+
+
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+        return
+        end
+
+      SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :             ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :             ,ep,clw,frac,m,mp,qp,up,vp
+     :             ,wt,water,evap
+     :             ,ment,qent,uent,vent,nent,elij
+     :             ,tv,tvp
+     o             ,iflag,wd,qprime,tprime
+     o             ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc), inb(nloc)
+      integer nent(nloc,nd)
+      real delt
+      real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real gz(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real hp(nloc,nd), lv(nloc,nd)
+      real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc)
+      real m(nloc,nd), mp(nloc,nd), qp(nloc,nd)
+      real up(nloc,nd), vp(nloc,nd)
+      real wt(nloc,nd), water(nloc,nd), evap(nloc,nd)
+      real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c outputs
+      integer iflag(nloc)  ! also an input
+      real cbmf(nloc)      ! also an input
+      real wd(nloc), tprime(nloc), qprime(nloc)
+      real precip(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd)
+
+c local variables
+      integer i,j,ij,k,num1
+      real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti
+      real work(nloc), am(nloc),amp1(nloc),ad(nloc)
+      real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld
+      real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd)     ! cld
+
+ 
+c -- initializations:
+
+      delti = 1.0/delt
+
+      do 160 i=1,ncum
+      precip(i)=0.0
+      wd(i)=0.0
+      tprime(i)=0.0
+      qprime(i)=0.0
+       do 170 k=1,nl+1
+        ft(i,k)=0.0
+        fu(i,k)=0.0
+        fv(i,k)=0.0
+        fq(i,k)=0.0
+        lvcp(i,k)=lv(i,k)/cpn(i,k)
+        qcondc(i,k)=0.0              ! cld
+        qcond(i,k)=0.0               ! cld
+        nqcond(i,k)=0.0              ! cld
+ 170   continue
+ 160  continue
+
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+      do i=1,ncum
+       wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i))
+     :           /(sigd*p(i,icb(i)))
+       qprime(i)=0.5*(qp(i,1)-q(i,1))
+       tprime(i)=lv0*qprime(i)/cpd
+      enddo
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+c (saturated updrafts resulting from mixing)               ! cld
+               qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld
+               nqcond(ij,i)=nqcond(ij,i)+1.                ! cld
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+C (saturated downdrafts resulting from mixing)               ! cld
+            do k=i+1,inb(ij)                                 ! cld
+             qcond(ij,i)=qcond(ij,i)+elij(ij,k,i)            ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            enddo                                            ! cld
+C (particular case: no detraining level is found)            ! cld
+            if (nent(ij,i).eq.0) then                        ! cld
+             qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            endif                                            ! cld
+            if (nqcond(ij,i).ne.0.) then                     ! cld
+             qcond(ij,i)=qcond(ij,i)/nqcond(ij,i)            ! cld
+            endif                                            ! cld
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+             qcondc(i,k)=0.0                               ! cld
+           endif
+ 1910    continue
+ 1920   continue
+
+        do k=1,nl+1
+        do i=1,ncum
+          Ma(i,k) = 0.
+        enddo
+        enddo
+        do k=nl,1,-1
+        do i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        enddo
+        enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+      DO ij=1,ncum                                          ! cld   
+       do i=1,nd                                            ! cld 
+        mac(ij,i)=0.0                                       ! cld   
+        wa(ij,i)=0.0                                        ! cld
+        siga(ij,i)=0.0                                      ! cld
+       enddo                                                ! cld
+       do i=nk(ij),inb(ij)                                  ! cld
+       do k=i+1,inb(ij)+1                                   ! cld
+        mac(ij,i)=mac(ij,i)+m(ij,k)                         ! cld
+       enddo                                                ! cld
+       enddo                                                ! cld
+       do i=icb(ij),inb(ij)-1                               ! cld
+        ax(ij,i)=0.                                         ! cld
+        do j=icb(ij),i                                      ! cld
+         ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j))         ! cld   
+     :       *(ph(ij,j)-ph(ij,j+1))/p(ij,j)                 ! cld   
+        enddo                                               ! cld
+        if (ax(ij,i).gt.0.0) then                           ! cld   
+         wa(ij,i)=sqrt(2.*ax(ij,i))                         ! cld
+        endif                                               ! cld
+       enddo                                                ! cld
+       do i=1,nl                                            ! cld
+        if (wa(ij,i).gt.0.0)                                ! cld
+     :    siga(ij,i)=mac(ij,i)/wa(ij,i)                     ! cld   
+     :        *rrd*tvp(ij,i)/p(ij,i)/100./delta             ! cld   
+        siga(ij,i) = min(siga(ij,i),1.0)                    ! cld
+        qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i))     ! cld   
+     :          + (1.-siga(ij,i))*qcond(ij,i)               ! cld   
+       enddo                                                ! cld
+      ENDDO                                                 ! cld   
+
+        return
+        end
+
+      SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum
+     :         ,iflag
+     :         ,precip,cbmf
+     :         ,ft,fq,fu,fv
+     :         ,Ma,qcondc            
+     :         ,iflag1
+     :         ,precip1,cbmf1
+     :         ,ft1,fq1,fu1,fv1
+     :         ,Ma1,qcondc1            
+     :                               )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len, ncum, nd, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc), cbmf(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd) !cld
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len), cbmf1(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real Ma1(len,nd)
+      real qcondc1(len,nd) !cld
+
+c local variables:
+      integer i,k
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cva_driver.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cva_driver.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cva_driver.F	(revision 984)
@@ -0,0 +1,926 @@
+      SUBROUTINE cva_driver(len,nd,ndp1,ntra,nloc,
+     &                   iflag_con,iflag_mix,
+     &                   iflag_clos,delt,
+     &                   t1,q1,qs1,t1_wake,q1_wake,qs1_wake,
+     &                   u1,v1,tra1,
+     &                   p1,ph1,
+     &                   ALE1,ALP1,
+     &                   sig1feed1,sig2feed1,wght1,
+     o                   iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,kbas1,ktop1,cbmf1,
+     &                   sig1,w01,                  !input/output
+     &                   ptop21,sigd,
+     &                   Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01,
+     &                   qcondc1,wd1,
+     &                   cape1,cin1,tvp1,
+     &                   ftd1,fqd1,
+     &                   Plim11,Plim21,asupmax1,supmax01,asupmaxmin1
+     &                   ,lalim_conv)
+***************************************************************
+*                                                             *
+* CV_DRIVER                                                   *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
+* modified by :                                               *
+***************************************************************
+***************************************************************
+C
+      USE dimphy
+      implicit none
+C
+C.............................START PROLOGUE............................
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+C      iflag_mix     Integer        Input        version of mixing  (0/1/2)
+C      iflag_clos    Integer        Input        version of closure (0/1)
+C      delt          Real           Input        time step
+C      t1            Real           Input        temperature (sat draught envt)
+C      q1            Real           Input        specific hum (sat draught envt)
+C      qs1           Real           Input        sat specific hum (sat draught envt)
+C      t1_wake       Real           Input        temperature (unsat draught envt)
+C      q1_wake       Real           Input        specific hum(unsat draught envt)
+C      qs1_wake      Real           Input        sat specific hum(unsat draughts envt)
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      ALE1          Real           Input        Available lifting Energy
+C      ALP1          Real           Input        Available lifting Power
+C      sig1feed1     Real           Input        sigma coord at lower bound of feeding layer
+C      sig2feed1     Real           Input        sigma coord at upper bound of feeding layer
+C      wght1         Real           Input        weight density determining the feeding mixture
+C      iflag1        Integer        Output       flag for Emanuel conditions
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      kbas1         Integer        Output       cloud base level
+C      ktop1         Integer        Output       cloud top level
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      ptop21        Real           In/Out       top of entraining zone
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      mip1          Real           Output       mass flux shed by the adiabatic updraft
+C      Vprecip1      Real           Output       vertical profile of precipitations
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+C      cin1          Real           Output       CIN
+C      tvp1          Real           Output       adiab lifted parcell virt temp
+C      ftd1          Real           Output       precip temp tend
+C      fqt1          Real           Output       precip spec hum tend
+C      Plim11        Real           Output
+C      Plim21        Real           Output
+C      asupmax1      Real           Output
+C      supmax01      Real           Output
+C      asupmaxmin1   Real           Output
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3)
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2)
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg)
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+#include "dimensions.h"
+ccccc#include "dimphy.h"
+c
+c Input
+      integer len
+      integer nd
+      integer ndp1
+      integer ntra
+      integer iflag_con
+      integer iflag_mix
+      integer iflag_clos
+      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 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 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
+c
+c 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 cbmflast(len)
+      real sig1(len,klev)      !input/output
+      real w01(len,klev)       !input/output
+      real ptop21(len)
+      real Ma1(len,nd)
+      real mip1(len,nd)
+      real Vprecip1(len,nd)
+      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)
+c
+      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)
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!
+! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!       Must be defined at same grid levels as T.
+!
+!qs_wake: Array of saturation specific humidity, seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!       Must be defined at same grid levels as T.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+! ALE:  Available lifting Energy
+!
+! ALP:  Available lifting Power
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!  ftd:  Array of temperature tendency due to precipitations (K/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fqd:  Array of specific humidity tendencies due to precipitations ((gm/gm)/s)
+!        of dimension ND, defined at same grid levels as T, Q, QS and P.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+
+      integer i,k,n,il,j
+      integer nword1,nword2,nword3,nword4
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer icbs1(klon)
+
+      logical ok_inhib  ! True => possible inhibition of convection by dryness
+      logical, save :: debut=.true. 
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real thnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real unk1(klon)
+      real vnk1(klon)
+      real cpnk1(klon)
+      real hnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev) ,lv1_wake(klon,klev)
+      real cpn1(klon,klev),cpn1_wake(klon,klev)
+      real tv1(klon,klev) ,tv1_wake(klon,klev)
+      real gz1(klon,klev) ,gz1_wake(klon,klev)
+      real hm1(klon,klev) ,hm1_wake(klon,klev)
+      real h1(klon,klev)  ,h1_wake(klon,klev)
+      real tp1(klon,klev)
+      real clw1(klon,klev)
+      real th1(klon,klev) ,th1_wake(klon,klev)
+c
+      real bid(klon,klev)   ! dummy array
+c
+      integer ncum
+c
+      integer j1feed(klon)
+      integer j2feed(klon)
+      real p1feed1(len) ! pressure at lower bound of feeding layer
+      real p2feed1(len) ! pressure at upper bound of feeding layer
+      real wghti1(len,nd) ! weights of the feeding layers
+c
+c (local) compressed fields:
+c
+      integer nloc
+c      parameter (nloc=klon) ! pour l'instant
+
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real t_wake(nloc,klev),q_wake(nloc,klev),qs_wake(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev)     ,hm(nloc,klev)
+      real               h_wake(nloc,klev),hm_wake(nloc,klev)
+      real lv(nloc,klev)     ,cpn(nloc,klev)
+      real lv_wake(nloc,klev),cpn_wake(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev)    ,tp(nloc,klev)
+      real                              tv_wake(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real                              th_wake(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev), ptop2(nloc)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real cin(nloc)
+      real m(nloc,klev)
+      real ment(nloc,klev,klev), sij(nloc,klev,klev)
+      real qent(nloc,klev,klev)
+      real hent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real elij(nloc,klev,klev)
+      real supmax(nloc,klev)
+      real ale(nloc),alp(nloc),coef_clos(nloc)
+      real sigd(nloc)
+!      real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+!      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+!      real b(nloc,klev), sigd(nloc)
+!      save mp,qp,up,vp,wt,water,evap,b
+      real, save, allocatable :: mp(:,:),qp(:,:),up(:,:),vp(:,:)
+      real, save, allocatable :: wt(:,:),water(:,:),evap(:,:), b(:,:)
+c$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,b)
+      real  ft(nloc,klev), fq(nloc,klev)
+      real ftd(nloc,klev), fqd(nloc,klev)
+      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 precip(nloc)
+      real Vprecip(nloc,klev)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,klev)
+      real supmax0(nloc)
+      real asupmaxmin(nloc)
+c
+      real tnk(nloc),qnk(nloc),gznk(nloc)
+      real wghti(nloc,nd)
+      real hnk(nloc),unk(nloc),vnk(nloc)
+      logical, save :: first=.true.
+
+c
+!      print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev)
+!      print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev)
+
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+       if (first) then
+         allocate(mp(nloc,klev), qp(nloc,klev), up(nloc,klev))
+         allocate(vp(nloc,klev), wt(nloc,klev), water(nloc,klev))
+         allocate(evap(nloc,klev), b(nloc,klev))
+         first=.false.
+       endif
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters
+c
+c 	includes microphysical parameters and parameters that
+c  	control the rate of approach to quasi-equilibrium)
+c 	(common cvparam)
+
+      if (iflag_con.eq.3) then
+       CALL cv3_param(nd,delt)
+  
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+      nword1=len
+      nword2=len*nd
+      nword3=len*nd*ntra
+      nword4=len*nd*nd
+ 
+!      call izilch(iflag1  ,nword1)
+!      call  zilch(iflag1  ,nword1)
+      do i=1,len
+         iflag1(i)=0
+         ktop1(i)=0
+         kbas1(i)=0
+      enddo
+      call  zilch(ft1     ,nword2)
+      call  zilch(fq1     ,nword2)
+      call  zilch(fu1     ,nword2)
+      call  zilch(fv1     ,nword2)
+      call  zilch(ftra1   ,nword3)
+      call  zilch(precip1 ,nword1)
+!      call izilch(kbas1   ,nword1)
+!      call  zilch(kbas1   ,nword1)
+!      call izilch(ktop1   ,nword1)
+!      call  zilch(ktop1   ,nword1)
+      call  zilch(cbmf1   ,nword1)
+      call  zilch(ptop21  ,nword1)
+      call  zilch(Ma1     ,nword2)
+      call  zilch(mip1    ,nword2)
+      call  zilch(Vprecip1,nword2)
+      call  zilch(upwd1   ,nword2)
+      call  zilch(dnwd1   ,nword2)
+      call  zilch(dnwd01  ,nword2)
+      call  zilch(qcondc1 ,nword2)
+!test
+!      call  zilch(qcondc ,nword2)
+      call  zilch(wd1     ,nword1)
+      call  zilch(cape1   ,nword1)
+      call  zilch(cin1    ,nword1)
+      call  zilch(tvp1    ,nword2)
+      call  zilch(ftd1    ,nword2)
+      call  zilch(fqd1    ,nword2)
+      call  zilch(Plim11  ,nword1)
+      call  zilch(Plim21  ,nword1)
+      call  zilch(asupmax1,nword2)
+      call  zilch(supmax01,nword1)
+      call  zilch(asupmaxmin1,nword1)
+c
+      DO il = 1,len
+       cin1(il) = -100000.
+       cape1(il) = -1.
+      ENDDO
+c  
+      if (iflag_con.eq.3) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+  
+!---------------------------------------------------------------------
+! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+!
+      do il = 1,nloc
+         coef_clos(il)=1.
+      enddo
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+  
+       if (debut) THEN 
+        print*,'Emanuel version 3 nouvelle'
+       endif 
+
+       CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1      ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+    
+c
+       CALL cv3_prelim(len,nd,ndp1,t1_wake,q1_wake,p1,ph1 ! nd->na
+     o               ,lv1_wake,cpn1_wake,tv1_wake,gz1_wake
+     o               ,h1_wake,bid,th1_wake)
+    
+      endif
+c
+      if (iflag_con.eq.4) then
+       print*,'Emanuel version 4 '
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+!
+! compute feeding layer potential temperature and mixing ratio :
+!
+! get bounds of feeding layer
+!
+c test niveaux couche alimentation KE
+       if(sig1feed1.eq.sig2feed1) then
+               print*,'impossible de choisir sig1feed=sig2feed'
+               print*,'changer la valeur de sig2feed dans physiq.def'
+       stop
+       endif
+c
+       do i=1,len
+         p1feed1(i)=sig1feed1*ph1(i,1)
+         p2feed1(i)=sig2feed1*ph1(i,1)
+ctest maf
+c         p1feed1(i)=ph1(i,1)
+c         p2feed1(i)=ph1(i,2)
+c         p2feed1(i)=ph1(i,3)
+ctestCR: on prend la couche alim des thermiques
+c          p2feed1(i)=ph1(i,lalim_conv(i)+1)
+c          print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
+       end do
+!
+       if (iflag_con.eq.3) then
+       endif
+      do i=1,len
+!      print*,'avant cv3_feed plim',p1feed1(i),p2feed1(i)
+      enddo
+      if (iflag_con.eq.3) then
+ 
+c     print*, 'IFLAG1 avant cv3_feed'
+c     print*,'len,nd',len,nd
+c     write(*,'(64i1)') iflag1(2:klon-1)
+
+       CALL cv3_feed(len,nd,t1,q1,u1,v1,p1,ph1,hm1,gz1           ! nd->na
+     i         ,p1feed1,p2feed1,wght1
+     o         ,wghti1,tnk1,thnk1,qnk1,qsnk1,unk1,vnk1
+     o         ,cpnk1,hnk1,nk1,icb1,icbmax,iflag1,gznk1,plcl1)
+      endif
+    
+c     print*, 'IFLAG1 apres cv3_feed'
+c     print*,'len,nd',len,nd
+c     write(*,'(64i1)') iflag1(2:klon-1)
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif
+c
+!      print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
+c
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content.
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+    
+       CALL cv3_undilute1(len,nd,t1,qs1,gz1,plcl1,p1,icb1,tnk1,qnk1  ! nd->na
+     o                    ,gznk1,tp1,tvp1,clw1,icbs1)
+      endif
+   
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+c
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+c
+!      print *,' avant triggering, iflag_con ',iflag_con
+c
+      if (iflag_con.eq.3) then
+    
+       CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1,thnk1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+    
+
+c     print*, 'IFLAG1 apres cv3_triger'
+c     print*,'len,nd',len,nd
+c     write(*,'(64i1)') iflag1(2:klon-1)
+
+c     call dump2d(iim,jjm-1,sig1(2)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+c
+c
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+c
+!       print*,'klon, ncum = ',len,ncum
+c
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+     
+       CALL 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,u1,v1,gz1,th1,th1_wake
+     :    ,tra1
+     :    ,h1     ,lv1     ,cpn1   ,p1,ph1,tv1    ,tp1,tvp1,clw1
+     :    ,h1_wake,lv1_wake,cpn1_wake     ,tv1_wake
+     :    ,sig1,w01,ptop21
+     :    ,Ale1,Alp1
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,hnk,unk,vnk
+     o    ,wghti,pbase,buoybase
+     o    ,t,q,qs,t_wake,q_wake,qs_wake,u,v,gz,th,th_wake
+     o    ,tra
+     o    ,h     ,lv     ,cpn    ,p,ph,tv    ,tp,tvp,clw
+     o    ,h_wake,lv_wake,cpn_wake    ,tv_wake
+     o    ,sig,w0,ptop2
+     o    ,Ale,Alp  ) 
+
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,hnk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+   
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+c
+!-------------------------------------------------------------------
+! --- MIXING(1)   (if iflag_mix .ge. 1)
+!-------------------------------------------------------------------
+      IF (iflag_con .eq. 3) THEN
+       IF (iflag_mix .ge. 1 ) THEN
+    
+         CALL cv3p_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                       ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                       ,unk,vnk,hp,tv,tvp,ep,clw,sig
+     :                    ,ment,qent,hent,uent,vent
+     :                   ,sij,elij,supmax,ments,qents,traent)
+!        print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
+      
+       ELSE
+        CALL zilch(supmax,nloc*klev)
+       ENDIF
+      ENDIF
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+c
+      if (iflag_con.eq.3) then
+       IF (iflag_clos .eq. 0) THEN
+        CALL cv3_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m,iflag)
+       ENDIF
+c
+       ok_inhib = iflag_mix .EQ. 2
+c
+       IF (iflag_clos .eq. 1) THEN
+        print *,' pas d appel cv3p_closure'
+cc        CALL cv3p_closure(nloc,ncum,nd,icb,inb              ! na->nd
+cc    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
+cc    :                       ,supmax
+cc    o                       ,sig,w0,ptop2,cape,cin,m)
+       ENDIF
+       IF (iflag_clos .eq. 2) THEN
+        CALL cv3p1_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,plcl,p,ph,tv,tvp,buoy
+     :                       ,supmax,ok_inhib,Ale,Alp
+     o                       ,sig,w0,ptop2,cape,cin,m,iflag,coef_clos
+     :                       ,Plim1,Plim2,asupmax,supmax0
+     :                       ,asupmaxmin,cbmf1)
+       ENDIF
+      endif   ! iflag_con.eq.3
+  
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+c
+!      print *,'cv_closure-> cape ',cape(1)
+c
+!-------------------------------------------------------------------
+! --- MIXING(2)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+        IF (iflag_mix.eq.0) THEN
+         CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                       ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                       ,unk,vnk,hp,tv,tvp,ep,clw,m,sig
+     o   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+         CALL zilch(hent,nloc*klev*klev)
+        ELSE
+         CALL cv3_mixscale(nloc,ncum,nd,ment,m)
+         if (debut) THEN 
+          print *,' cv3_mixscale-> '
+         endif !(debut) THEN 
+        ENDIF
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+c
+      if (debut) THEN 
+       print *,' cv_mixing ->'
+      endif !(debut) THEN 
+c      do i = 1,klev
+c        print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev)
+c      enddo
+c
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+      if (iflag_con.eq.3) then
+       if (debut) THEN 
+        print *,' cva_driver -> cv3_unsat '
+       endif !(debut) THEN 
+    
+       CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb,iflag    ! na->nd
+     :               ,t_wake,q_wake,qs_wake,gz,u,v,tra,p,ph
+     :               ,th_wake,tv_wake,lv_wake,cpn_wake
+     :               ,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl,coef_clos
+     o          ,mp,qp,up,vp,trap,wt,water,evap,b,sigd)
+      endif
+     
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+c
+      if (debut) THEN 
+       print *,'cv_unsat-> '
+       debut=.FALSE.
+      endif !(debut) THEN
+!
+c      print *,'cv_unsat-> mp ',mp
+c      print *,'cv_unsat-> water ',water
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+  
+       CALL cv3_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,t_wake,q_wake,u,v,tra
+     :                     ,gz,p,ph,h,hp,lv,cpn,th
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b,sigd
+     :                    ,ment,qent,hent,iflag_mix,uent,vent
+     :                    ,nent,elij,traent,sig
+     :                    ,tv,tvp,wghti
+     :                    ,iflag,precip,Vprecip,ft,fq,fu,fv,ftra
+     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+     :                    ,tls,tps,qcondc,wd
+     :                    ,ftd,fqd)
+!      print *,' cv3_yield -> fqd(1) = ',fqd(1,1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,t_wake,q_wake,u,v,tra
+     :              ,gz,p,ph,h,hp,lv,cpn,th
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+      if (iflag_con.eq.3) then
+       CALL cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag,icb,inb
+     :          ,precip,sig,w0,ptop2
+     :          ,ft,fq,fu,fv,ftra
+     :          ,Ma,mip,Vprecip,upwd,dnwd,dnwd0
+     ;          ,qcondc,wd,cape,cin
+     :          ,tvp
+     :          ,ftd,fqd
+     :          ,Plim1,Plim2,asupmax,supmax0
+     :          ,asupmaxmin
+     o          ,iflag1,kbas1,ktop1
+     o          ,precip1,sig1,w01,ptop21
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01
+     o          ,qcondc1,wd1,cape1,cin1
+     o          ,tvp1
+     o          ,ftd1,fqd1
+     o          ,Plim11,Plim21,asupmax1,supmax01
+     o          ,asupmaxmin1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cvflag.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cvflag.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cvflag.h	(revision 984)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      logical cvflag_grav
+
+      COMMON /cvflag/ cvflag_grav 
+c$OMP THREADPRIVATE(/cvflag/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cvltr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cvltr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cvltr.F	(revision 984)
@@ -0,0 +1,145 @@
+c
+c $Header$
+c
+      SUBROUTINE cvltr(pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx)
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : convection des traceurs / KE
+c Auteurs: M-A Filiberti and J-Y Grandpeix
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+      REAL paprs(klon,klev+1) ! pression aux 1/2 couches (bas en haut)
+      REAL pplay(klon,klev)  ! pression pour le milieu de chaque couche
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+      REAL upd(klon,klev)      ! saturated updraft mass flux
+      REAL dnd(klon,klev)      ! saturated downdraft mass flux
+c
+c--variables locales      
+      real zed(klon,klev),zmd(klon,klev,klev)
+      real za(klon,klev,klev)
+      real zmfd(klon,klev),zmfa(klon,klev)
+      real zmfp(klon,klev),zmfu(klon,klev)
+      integer i,k,j 
+c test conservation
+c      real conserv
+c =========================================
+c calcul des tendances liees au downdraft
+c =========================================
+      zed(:,:)=0.
+      zmfd(:,:)=0.
+      zmfa(:,:)=0.
+      zmfu(:,:)=0.
+      zmfp(:,:)=0.
+      zmd(:,:,:)=0.
+      za(:,:,:)=0.
+c entrainement
+      do k=1,klev-1
+        do i=1,klon
+          zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
+        end do
+      end do
+c
+c calcul de la matrice d echange
+c matrice de distribution de la masse entrainee en k
+c
+      do k=1,klev
+        do i=1,klon
+          zmd(i,k,k)=zed(i,k)
+        end do
+      end do
+      do k=2,klev
+        do j=k-1,1,-1
+          do i=1,klon
+          if(mp(i,j+1).ne.0) then
+          zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
+          endif
+          end do
+        end do
+      end do
+      do k=1,klev
+        do j=1,klev-1
+          do i=1,klon
+          za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+          end do
+        end do
+      end do
+c
+c rajout du terme lie a l ascendance induite
+c
+        do j=2,klev
+         do i=1,klon
+          za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+         end do
+        end do
+C
+c tendances
+c            
+      do k=1,klev
+        do j=1,klev
+          do i=1,klon
+          zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k)-x(i,j))
+          end do
+        end do
+      end do
+c
+c =========================================
+c calcul des tendances liees aux flux satures
+c =========================================
+      do j=1,klev
+        do i=1,klon
+          zmfa(i,j)=da(i,j)*(x(i,1)-x(i,j))
+        end do
+      end do
+      do k=1,klev
+        do j=1,klev
+          do i=1,klon
+          zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k)-x(i,j))
+          end do
+        end do
+      end do
+      do j=1,klev-1
+        do i=1,klon
+          zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1)-x(i,j))
+        end do
+      end do
+      do j=2,klev
+        do i=1,klon
+          zmfu(i,j)=zmfu(i,j)
+     .             +min(0.,upd(i,j)+dnd(i,j))*(x(i,j)-x(i,j-1))
+        end do
+      end do
+
+c =========================================
+c--calcul final des tendances
+c =========================================
+      do k=1, klev
+        do i=1, klon
+          dx(i,k)=(zmfd(i,k)+zmfu(i,k)
+     .      +zmfa(i,k)+zmfp(i,k))*pdtime
+     .      *RG/(paprs(i,k)-paprs(i,k+1))
+c          print*,'dx',k,dx(i,k)
+        enddo
+      enddo
+c
+c test de conservation du traceur
+c      conserv=0.
+c      do k=1, klev
+c        do i=1, klon
+c         conserv=conserv+dx(i,k)*
+c     .     (paprs(i,k)-paprs(i,k+1))/RG
+C
+c        enddo
+c      enddo
+c      print *,'conserv',conserv
+     
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cvparam.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cvparam.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cvparam.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+c------------------------------------------------------------
+c Parameters for convectL:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real elcrit, tlcrit
+      real entp
+      real sigs, sigd
+      real omtrain, omtsnow, coeffr, coeffs
+      real dtmax
+      real cu
+      real betad
+      real alpha, damp
+      real delta
+
+      COMMON /cvparam/ noff, minorig, nl, nlp, nlm
+     :                ,elcrit, tlcrit
+     :                ,entp, sigs, sigd
+     :                ,omtrain, omtsnow, coeffr, coeffs
+     :                ,dtmax, cu, betad, alpha, damp, delta
+
+c$OMP THREADPRIVATE(/cvparam/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/cvthermo.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/cvthermo.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/cvthermo.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c Thermodynamical constants for convectL:
+
+      real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+      real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl
+      real eps, epsi, epsim1
+      real ginv, hrd
+      real grav
+
+      COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+     :                 ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl 
+     :                 ,eps, epsi, epsim1, ginv, hrd, grav
+
+c$OMP THREADPRIVATE(/cvthermo/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/diagphy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/diagphy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/diagphy.F	(revision 984)
@@ -0,0 +1,415 @@
+!
+! $Header$
+!
+      SUBROUTINE diagphy(airephy,tit,iprt
+     $    , tops, topl, sols, soll, sens
+     $    , evap, rain_fall, snow_fall, ts
+     $    , d_etp_tot, d_qt_tot, d_ec_tot
+     $    , fs_bound, fq_bound)
+C======================================================================
+C
+C Purpose:
+C    Compute the thermal flux and the watter mass flux at the atmosphere
+c    boundaries. Print them and also the atmospheric enthalpy change and
+C    the  atmospheric mass change.
+C
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+C                   (i.e. -1 * flux absorbed by the surface)
+C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+C                   (i.e. flux emited - flux absorbed by the surface)
+C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+C                   (kg/m2/s), positive up
+C rain_fall(klon)
+C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+C snow_fall(klon)
+C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+C ts(klon)----input-R- Surface temperature (K)
+C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+C                    change (W/m2)
+C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+C                    change (kg/m2/s)
+C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+C                    change (W/m2)
+C
+C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+C
+C J.L. Dufresne, July 2002
+C Version prise sur ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
+C  le 25 Novembre 2002.
+C======================================================================
+C 
+      use dimphy
+      implicit none
+
+#include "dimensions.h"
+ccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+c     Output variables
+      REAL fs_bound, fq_bound
+C
+C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+C
+      integer i
+C
+      integer pas
+      save pas
+      data pas/0/
+c$OMP THREADPRIVATE(pas)
+C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+C
+C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+C     la glace, on travaille par difference a la chaleur specifique de l'
+c     air sec. En effet, comme on travaille a niveau de pression donne,
+C     toute variation de la masse d'un constituant est totalement
+c     compense par une variation de masse d'air.
+C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront
+     $         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice
+     $           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront
+     $    + slat
+C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+C
+      IF (iprt.ge.1) write(6,6666) 
+     $    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+C
+      IF (iprt.ge.1) write(6,6668) 
+     $    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+C
+      IF (iprt.ge.2) write(6,6667) 
+     $    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot
+     $    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end
+
+C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime
+     e  ,t,q,ql,qs,u,v,paprs,pplay
+     s  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la physique. Suppose que les niveau de
+c    pression entre couche ne varie pas entre 2 appels.
+C
+C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+c bilans sont sauvegardes dans des tableaux indices. On parlera
+C "d'indice de diagnostic"
+c 
+C
+c======================================================================
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c qs-------input-R- solid watter (kg/kg)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c paprs----input-R- pression a intercouche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C     other (COMMON...)
+C     RCPD, RCPV, ....
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      USE dimphy
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+cccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+c$OMP THREADPRIVATE(pas)
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+c$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+c$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+c======================================================================
+C
+      DO k = 1, klev
+        DO i = 1, klon
+C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+C
+C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i) 
+     $        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*ql(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*qs(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+      RETURN 
+      END 
Index: LMDZ4/tags/LF_20080728/libf/phylmd/dimphy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/dimphy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/dimphy.F90	(revision 984)
@@ -0,0 +1,43 @@
+MODULE dimphy
+  
+  INTEGER,SAVE :: klon
+  INTEGER,SAVE :: kdlon
+  INTEGER,SAVE :: kfdia
+  INTEGER,SAVE :: kidia
+  INTEGER,SAVE :: nbtr 
+  INTEGER,SAVE :: klev
+  INTEGER,SAVE :: klevp1
+  INTEGER,SAVE :: klevm1
+  INTEGER,SAVE :: kflev
+
+!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
+  REAL,save,allocatable,dimension(:) :: zmasq
+!$OMP THREADPRIVATE(zmasq)   
+
+CONTAINS
+  
+  SUBROUTINE Init_dimphy(klon0,klev0,nbtr0)
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    INTEGER, INTENT(in) :: nbtr0
+    
+    klon=klon0
+    
+    kdlon=klon
+    kidia=1
+    kfdia=klon
+!$OMP MASTER 
+    klev=klev0
+    nbtr=nbtr0
+    klevp1=klev+1
+    klevm1=klev-1
+    kflev=klev
+!$OMP END MASTER    
+    ALLOCATE(zmasq(klon))    
+    
+  END SUBROUTINE Init_dimphy
+
+  
+END MODULE dimphy
Index: LMDZ4/tags/LF_20080728/libf/phylmd/dimsoil.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/dimsoil.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/dimsoil.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER nsoilmx
+      PARAMETER (nsoilmx=11)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ecribin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ecribin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ecribin.F	(revision 984)
@@ -0,0 +1,104 @@
+!
+! $Header$
+!
+      SUBROUTINE ecribins(unit,pz)
+      USE dimphy
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim +1,jjm+1)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim +1
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+            zz(iim+1,j)=zz(1,j)
+         ENDDO
+c-----------------------------------------------------------------------
+#ifdef VPP
+      CALL ecriture(unit,zz,(iim+1)*(jjm+1))
+#else
+      WRITE(unit) zz
+#endif
+c
+
+      RETURN
+      END
+      SUBROUTINE ecribina(unit,pz)
+      USE dimphy
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim+1,jjm+1,llm)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim +1
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+            zz(iim+1,j,ilay)=zz(1,j,ilay)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+#ifdef VPP
+         CALL ecriture(unit, zz(1,1,ilay), (iim+1)*(jjm+1))
+#else
+         WRITE(unit) ((zz(i,j,ilay),i=1,iim +1),j=1,jjm+1)
+#endif
+      ENDDO
+c
+      RETURN
+      END
+#ifdef VPP
+@OPTIONS NODOUBLE
+      SUBROUTINE ecriture(nunit, r8, n)
+      INTEGER nunit, n, i
+      REAL*8 r8(n)
+      REAL*4 r4(n)
+      DO i = 1, n
+         r4(i) = r8(i)
+      ENDDO
+      WRITE(nunit)r4
+      RETURN
+      END
+#endif
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ecrireg.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ecrireg.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ecrireg.F	(revision 984)
@@ -0,0 +1,121 @@
+!
+! $Header$
+!
+      SUBROUTINE ecriregs(unit,pz)
+      use dimphy
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim,jjm+1)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+         ENDDO
+c-----------------------------------------------------------------------
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      RETURN
+      END
+      SUBROUTINE ecrirega(unit,pz)
+      USE dimphy
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim,jjm+1,llm)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp.F	(revision 984)
@@ -0,0 +1,548 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,ratqs,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl, rhcl)
+
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+#include "fisrtilp.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rhcl(klon,klev) ! humidite relative en ciel clair
+      REAL rain(klon) ! pluies (mm/s)
+      REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+cAA
+c Coeffients de fraction lessivee : pour OFF-LINE
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+      real zct(klon),zcl(klon)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+
+      INTEGER ninter ! sous-intervals pour la precipitation
+      INTEGER ncoreczq
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur
+
+      real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
+      real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon)
+      real erf
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c$OMP THREADPRIVATE(a_tr_sca)
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+      REAL zmair, zcpair, zcpeau
+C     Pour la conversion eau-neige
+      REAL zlh_solid(klon), zm_solid
+cIM 
+cym      INTEGER klevm1
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
+      fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
+c
+      DATA appel1er /.TRUE./
+cym
+      zdelq=0.0
+      
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+c         CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c  nexpo regle la raideur de la transition eau liquide / eau glace.
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+      ncoreczq=0
+c Boucle verticale (du haut vers le bas)
+c
+cIM : klevm1
+cym      klevm1=klev-1
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer la varition de temp. de l'air du a la chaleur sensible
+C transporter par la pluie.
+C Il resterait a rajouter cet effet de la chaleur sensible sur les
+C flux de surface, du a la diff. de temp. entre le 1er niveau et la
+C surface.
+C
+      DO i = 1, klon
+cIM
+       IF(k.LE.klevm1) THEN         
+        zmair=(paprs(i,k)-paprs(i,k+1))/RG
+        zcpair=RCPD*(1.0+RVTMP2*zq(i))
+        zcpeau=RCPD*RVTMP2
+        zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau
+     $      + zmair*zcpair*zt(i) )
+     $      / (zmair*zcpair + zrfl(i)*dtime*zcpeau)
+CC        WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1))
+       ENDIF
+      ENDDO
+c
+c
+c Calculer l'evaporation de la precipitation
+c
+
+
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+
+c pour la glace, on r�vapore toute la pr�ip dans la couche du dessous
+c la glace venant de la couche du dessus est simplement dans la couche
+c du dessous.
+
+         IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
+
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+
+c        print*,'Dans partiel k=',k
+c
+c   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
+c   nuageuse a partir des PDF de Sandrine Bony.
+c   rneb  : fraction nuageuse
+c   zqn   : eau totale dans le nuage
+c   zcond : eau condensee moyenne dans la maille.
+c           on prend en compte le r�hauffement qui diminue la partie condensee
+c
+c   Version avec les raqts
+
+         if (iflag_pdf.eq.0) then
+
+           do i=1,klon
+            zdelq = min(ratqs(i,k),0.99) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+           enddo
+
+         else
+c
+c   Version avec les nouvelles PDFs.
+           do i=1,klon
+              if(zq(i).lt.1.e-15) then
+                ncoreczq=ncoreczq+1
+                zq(i)=1.e-15
+              endif
+           enddo
+           do i=1,klon
+            zpdf_sig(i)=ratqs(i,k)*zq(i)
+            zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+            zpdf_delta(i)=log(zq(i)/zqs(i))
+            zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+            zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+            zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+            zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
+            zpdf_e1(i)=1.-erf(zpdf_e1(i))
+            zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+            zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
+            zpdf_e2(i)=1.-erf(zpdf_e2(i))
+            if (zpdf_e1(i).lt.1.e-10) then
+               rneb(i,k)=0.
+               zqn(i)=zqs(i)
+            else
+               rneb(i,k)=0.5*zpdf_e1(i)
+               zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+            endif
+            
+           enddo
+
+        endif ! iflag_pdf
+
+         do i=1,klon
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+c           zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+c  On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par
+c  la convection.
+c  ATTENTION !!! Il va falloir verifier tout ca.
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+c           print*,'ZDQS ',zdqs(i)
+c--Olivier
+            rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0
+c--fin
+           ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+c         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+
+         if (ptconv(i,k)) then
+            zcl(i)=cld_lc_con
+            zct(i)=1./cld_tau_con
+         else
+            zcl(i)=cld_lc_lsc
+            zct(i)=1./cld_tau_lsc
+         endif
+c  quantit�d'eau ��minier.
+         zchau(i) = zct(i)*dtime/FLOAT(ninter) * zoliq(i)
+     .         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl(i))**2)) *(1.-zfice(i))
+c  meme chose pour la glace.
+         if (ptconv(i,k)) then
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvc(zrhol(i)) * zfice(i)
+         else
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvs(zrhol(i)) * zfice(i)
+         endif
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+      ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
+      ENDDO
+c
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
+cAA Lessivage par impaction dans les couches en-dessous
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
+c
+cAA----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+         zlh_solid(i) = RLSTT-RLVTT
+      ELSE
+         rain(i) = zrfl(i)
+         zlh_solid(i) = 0.
+      ENDIF
+      ENDDO
+C
+C For energy conservation : when snow is present, the solification
+c latent heat is considered.
+      DO k = 1, klev
+        DO i = 1, klon
+          zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
+          zmair=(paprs(i,k)-paprs(i,k+1))/RG
+          zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
+          d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair)
+        END DO 
+      END DO
+c
+
+      if (ncoreczq>0) then
+         print*,'WARNING : ZQ dans fisrtilp ',ncoreczq,' val < 1.e-15.'
+      endif
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp.h	(revision 984)
@@ -0,0 +1,28 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+      REAL cld_lc_lsc,cld_lc_con
+      REAL cld_tau_lsc,cld_tau_con
+      REAL ffallv_lsc,ffallv_con
+      REAL coef_eva
+      LOGICAL reevap_ice
+      INTEGER iflag_pdf
+
+      common/comfisrtilp/                                               &
+     &     cld_lc_lsc                                                   &
+     &     ,cld_lc_con                                                  &
+     &     ,cld_tau_lsc                                                 &
+     &     ,cld_tau_con                                                 &
+     &     ,ffallv_lsc                                                  &
+     &     ,ffallv_con                                                  &
+     &     ,coef_eva                                                    &
+     &     ,reevap_ice                                                  &
+     &     ,iflag_pdf        
+
+!$OMP THREADPRIVATE(/comfisrtilp/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp_tr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp_tr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/fisrtilp_tr.F	(revision 984)
@@ -0,0 +1,435 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,ratqs,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl,
+     s                   RHcl) ! relative humidity in clear sky (needed for aer optical properties; aeropt.F)
+
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rain(klon) ! pluies (mm/s)
+      REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      
+Cjq   For aerosol opt properties needed (see aeropt.F)
+      REAL RHcl(klon,klev)
+      
+cAA
+c Coeffients de fraction lessivee : pour OFF-LINE
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+      REAL ct ! inverse du temps pour qu'un nuage precipite
+      PARAMETER (ct=1./1800.)
+      REAL cl ! seuil de precipitation
+      PARAMETER (cl=2.6e-4)
+ccc      PARAMETER (cl=2.3e-4)
+ccc      PARAMETER (cl=2.0e-4)
+      INTEGER ninter ! sous-intervals pour la precipitation
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=2.0E-05)
+      LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      PARAMETER (calcrat=.TRUE.)
+      REAL zx_min, rat_max
+      PARAMETER (zx_min=1.0, rat_max=0.01)
+      REAL zx_max, rat_min
+      PARAMETER (zx_max=0.1, rat_min=0.3)
+      REAL zx
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c$OMP THREADPRIVATE(a_tr_sca)
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallv ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallv (zzz) = 3.29/2.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29 * ((zzz)**0.16)
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, calcrat:', calcrat
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+          CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer l'evaporation de la precipitation
+c
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+         DO i = 1, klon
+c
+            zdelq = ratqs(i,k) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+            
+c--Olivier
+            RHcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) RHcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) RHcl(i,k)=1.0
+c--fin
+            
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zchau(i) = ct*dtime/FLOAT(ninter) * zoliq(i)
+     .          * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i))
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+         zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallv(zrhol(i)) * zfice(i)
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+      ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
+      ENDDO
+c
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
+cAA Lessivage par impaction dans les couches en-dessous
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
+c
+cAA----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+      ELSE
+         rain(i) = zrfl(i)
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/flxtr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/flxtr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/flxtr.F	(revision 984)
@@ -0,0 +1,207 @@
+!
+! $Header$
+!
+      SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) 
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux, kcbot, kctop et kdtop
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --Un schema amont est choisi pour calculer les flux pour s'assurer 
+c   de la positivite des valeurs de traceurs, cela implique des eqs 
+c   differentes pour les flux de traceurs montants et descendants.
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant 
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+c--idem mais en variables locales
+      REAL zpen_u(klon,klev) 
+      REAL zpde_u(klon,klev)
+      REAL zpen_d(klon,klev) 
+      REAL zpde_d(klon,klev)
+c
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL pap(klon,klev)      ! pression aux couches (haut en bas)
+      REAL pt(klon,klev)       ! temperature aux couches (bas en haut) 
+      REAL zt(klon,klev)       ! temperature aux couches (haut en bas)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL paph(klon,klev+1)   ! pression aux 1/2 couches (haut en bas)
+      INTEGER kcbot(klon)      ! niveau de base de la convection
+      INTEGER kctop(klon)      ! niveau du sommet de la convection +1 
+      INTEGER kdtop(klon)      ! niveau de sommet du panache descendant
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL zx(klon,klev)       ! q de traceur (haut en bas)
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL xe(klon,klev)        ! q de traceurs dans l'environnement 
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+c
+c On remet les taux d'entrainement et de detrainement dans le panache
+c descendant a des valeurs positives. 
+c On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la 
+c conservation de la masse soit realisee a chaque niveau dans les 2 
+c panaches.
+      DO k=1, klev
+      DO i=1, klon
+        zpen_u(i,k)= pen_u(i,k)
+        zpde_u(i,k)= pde_u(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO k=1, klev-1
+      DO i=1, klon
+        zpen_d(i,k)=-pen_d(i,k+1)
+        zpde_d(i,k)=-pde_d(i,k+1)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon 
+      zpen_d(i,klev)       = 0.0
+      zpde_d(i,klev)       = -pmfd(i,klev)
+c   Correction 03 11 97
+c     zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      IF (kdtop(i).EQ.klev+1) THEN
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)
+      ELSE
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      ENDIF
+
+      zpde_u(i,kctop(i)-2) = pmfu(i,kctop(i)-1)
+      zpen_u(i,klev)       = pmfu(i,klev) 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=kcbot(i), klev-1
+      zpen_u(i,k) = pmfu(i,k) - pmfu(i,k+1)
+      ENDDO 
+      ENDDO 
+c
+c conversion des sens de notations bas-haut et haut-bas
+c
+      DO k=1, klev+1 
+      DO i=1, klon 
+        paph(i,klev+2-k)=paprs(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=1, klev 
+        pap(i,klev+1-k)=pplay(i,k)
+        zt(i,klev+1-k) =pt(i,k)
+        zx(i,klev+1-k) =x(i,k) 
+      ENDDO 
+      ENDDO
+c
+c--initialisations des flux de traceurs aux extremites de la colonne
+c
+      DO i=1, klon 
+        zmfux(i,klev+1) = 0.0 
+        zmfdx(i,1) = 0.0 
+        zmfex(i,1) = 0.0 
+      ENDDO
+c
+c--calcul des flux dans le panache montant
+c
+      DO k=klev, 1, -1
+      DO i=1, klon
+       IF (k.GE.kcbot(i)) THEN 
+         xu(i,k)=zx(i,k)
+         zmfux(i,k)=pmfu(i,k)*xu(i,k)
+       ELSE 
+         zmfux(i,k)= (zmfux(i,k+1) + zpen_u(i,k)*zx(i,k) ) / 
+     .               (1.+zpde_u(i,k)/MAX(zmfmin,pmfu(i,k)))
+         xu(i,k)=zmfux(i,k)/MAX(zmfmin,pmfu(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c--calcul des flux dans le panache descendant
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kdtop(i)-1) THEN
+         xd(i,k)=( zx(i,k)+xu(i,k) ) / 2. 
+         zmfdx(i,k+1)=pmfd(i,k+1)*xd(i,k)
+       ELSE
+         zmfdx(i,k+1)= (zmfdx(i,k) - zpen_d(i,k)*zx(i,k) ) /
+     .               (1.-zpde_d(i,k)/MIN(-zmfmin,pmfd(i,k+1)))
+         xd(i,k)=zmfdx(i,k+1)/MIN(-zmfmin,pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfdx(i,klev+1) = 0.0 
+         xd(i,klev) = (zpen_d(i,klev)*zx(i,klev) - zmfdx(i,klev)) / 
+     .                   MAX(zmfmin,zpde_d(i,klev)) 
+      ENDDO 
+c
+c--introduction du flux de retour dans l'environnement
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kctop(i)-3) THEN 
+         xe(i,k)= zx(i,k) 
+         zmfex(i,k+1)=-(pmfu(i,k+1)+pmfd(i,k+1))*xe(i,k)
+       ELSE 
+         zmfex(i,k+1)= (zmfex(i,k) - 
+     .      (zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i,k))) /
+     .      (1.-(zpen_d(i,k)+zpen_u(i,k))/
+     .      MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) )
+         xe(i,k)=zmfex(i,k+1)/MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfex(i,klev+1) = 0.0
+         xe(i,klev) = (zpde_u(i,klev)*xu(i,klev) + 
+     .                 zpde_d(i,klev)*xd(i,klev) -zmfex(i,klev)) /
+     .                 MAX(zmfmin,zpen_u(i,klev)+zpen_d(i,klev)) 
+      ENDDO
+c
+c--calcul final des tendances
+c
+      DO k=1 , klev
+      DO i=1, klon
+        dx(i,klev+1-k) = RG/(paph(i,k+1)-paph(i,k))*pdtime*
+     .                      ( zmfux(i,k+1) - zmfux(i,k) +
+     .                        zmfdx(i,k+1) - zmfdx(i,k) +
+     .                        zmfex(i,k+1) - zmfex(i,k) )
+      ENDDO
+      ENDDO
+c
+      RETURN 
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/fonte_neige_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/fonte_neige_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/fonte_neige_mod.F90	(revision 984)
@@ -0,0 +1,343 @@
+!
+! $Header$
+!
+MODULE fonte_neige_mod
+!
+! This module will treat the process of snow, melting, accumulating, calving, in 
+! case of simplified soil model.
+!
+!****************************************************************************************
+  USE dimphy, ONLY : klon
+
+  IMPLICIT NONE
+  SAVE
+
+! run_off_ter and run_off_lic are the runoff at the compressed grid knon for 
+! land and land-ice respectively
+! Note: run_off_lic is used in mod_landice and therfore not private
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_ter
+  !$OMP THREADPRIVATE(run_off_ter)
+  REAL, ALLOCATABLE, DIMENSION(:)             :: run_off_lic
+  !$OMP THREADPRIVATE(run_off_lic)
+
+! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_lic_0
+  !$OMP THREADPRIVATE(run_off_lic_0)
+  
+  REAL, PRIVATE                               :: tau_calv  
+  !$OMP THREADPRIVATE(tau_calv)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: ffonte_global
+  !$OMP THREADPRIVATE(ffonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqfonte_global
+  !$OMP THREADPRIVATE(fqfonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqcalving_global
+  !$OMP THREADPRIVATE(fqcalving_global)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_init(restart_runoff)
+
+! This subroutine allocates and initialize variables in the module. 
+! The variable run_off_lic_0 is initialized to the field read from
+! restart file. The other variables are initialized to zero.
+!
+    INCLUDE "indicesol.h"
+!****************************************************************************************
+! Input argument
+    REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff 
+
+! Local variables
+    INTEGER                           :: error
+    CHARACTER (len = 80)              :: abort_message 
+    CHARACTER (len = 20)              :: modname = 'fonte_neige_init'
+
+
+!****************************************************************************************
+! Allocate run-off at landice and initilize with field read from restart
+!
+!****************************************************************************************
+
+    ALLOCATE(run_off_lic_0(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic_0(:) = restart_runoff(:) 
+
+!****************************************************************************************
+! Allocate other variables and initilize to zero
+!
+!****************************************************************************************
+    ALLOCATE(run_off_ter(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_ter'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_ter(:) = 0.
+    
+    ALLOCATE(run_off_lic(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic(:) = 0.
+    
+    ALLOCATE(ffonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation ffonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    ffonte_global(:,:) = 0.0
+
+    ALLOCATE(fqfonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqfonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqfonte_global(:,:) = 0.0
+
+    ALLOCATE(fqcalving_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqcalving_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqcalving_global(:,:) = 0.0
+
+!****************************************************************************************
+! Read tau_calv
+!
+!****************************************************************************************
+    CALL conf_interface(tau_calv)
+
+
+  END SUBROUTINE fonte_neige_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, &
+       tsurf, precip_rain, precip_snow, &
+       snow, qsol, tsurf_new, evap)
+        
+! Routine de traitement de la fonte de la neige dans le cas du traitement
+! de sol simplifie!
+! LF 03/2001
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   knindex      index des mailles valables pour surface a traiter
+!   dtime        
+!   tsurf        temperature de surface
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!
+! input/output:
+!   snow         champs hauteur de neige
+!   qsol         hauteur d'eau contenu dans le sol
+!   tsurf_new    temperature au sol
+!   evap
+!
+  INCLUDE "indicesol.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "FCTTRE.h"
+  INCLUDE "clesphys.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, INTENT(IN)                  :: nisurf
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+    
+! Input/Output variables
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: qsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(INOUT) :: evap
+
+! Local variables
+!****************************************************************************************
+
+    INTEGER               :: i, j
+    REAL                  :: fq_fonte
+    REAL                  :: coeff_rel
+    REAL, PARAMETER       :: snow_max=3000.
+    REAL, PARAMETER       :: max_eau_sol = 150.0
+!! PB temporaire en attendant mieux pour le modele de neige
+! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15)
+    REAL, PARAMETER       :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!IM cf JLD/ GKtest
+    REAL, PARAMETER       :: chaice = 3.334E+05/(2.3867E+06*0.15)
+! fin GKtest
+    REAL, DIMENSION(klon) :: ffonte
+    REAL, DIMENSION(klon) :: fqcalving, fqfonte
+    REAL, DIMENSION(klon) :: d_ts
+    REAL, DIMENSION(klon) :: bil_eau_s, snow_evap
+
+    LOGICAL               :: neige_fond
+
+!****************************************************************************************
+! Start calculation
+! - Initialization
+!
+!****************************************************************************************
+    coeff_rel = dtime/(tau_calv * rday)
+    
+    bil_eau_s(:) = 0.
+
+!****************************************************************************************
+! - Increment snow due to precipitation and evaporation
+! - Calculate the water balance due to precipitation and evaporation (bil_eau_s)
+!
+!****************************************************************************************
+    WHERE (precip_snow > 0.) 
+       snow = snow + (precip_snow * dtime)
+    END WHERE
+
+    snow_evap = 0.
+    WHERE (evap > 0. ) 
+       snow_evap = MIN (snow / dtime, evap) 
+       snow = snow - snow_evap * dtime
+       snow = MAX(0.0, snow)
+    END WHERE
+    
+    bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime
+
+
+!****************************************************************************************
+! - Calculate melting snow
+! - Calculate calving and decrement snow, if there are to much snow
+! - Update temperature at surface
+!
+!****************************************************************************************
+
+    ffonte(:) = 0.0
+    fqcalving(:) = 0.0
+    fqfonte(:) = 0.0
+    DO i = 1, knon
+       ! Y'a-t-il fonte de neige?
+       neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+            .AND. tsurf_new(i) >= RTT)
+       IF (neige_fond) THEN
+          fq_fonte     = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
+          ffonte(i)    = fq_fonte * RLMLT/dtime
+          fqfonte(i)   = fq_fonte/dtime
+          snow(i)      = MAX(0., snow(i) - fq_fonte)
+          bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
+          tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+
+!IM cf JLD OK     
+!IM cf JLD/ GKtest fonte aussi pour la glace
+          IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN
+             fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0)
+             ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime
+             IF ( ok_lic_melt ) THEN
+                fqfonte(i) = fqfonte(i) + fq_fonte/dtime
+                bil_eau_s(i) = bil_eau_s(i) + fq_fonte
+             ENDIF
+             tsurf_new(i) = RTT
+          ENDIF
+          d_ts(i) = tsurf_new(i) - tsurf(i)
+       ENDIF
+
+       ! s'il y a une hauteur trop importante de neige, elle s'coule
+       fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime
+       snow(i)=MIN(snow(i),snow_max)
+    END DO
+
+
+    IF (nisurf == is_ter) THEN
+       DO i = 1, knon
+          qsol(i) = qsol(i) + bil_eau_s(i)
+          run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+          qsol(i) = MIN(qsol(i), max_eau_sol) 
+       END DO
+    ELSE IF (nisurf == is_lic) THEN
+       DO i = 1, knon
+          j = knindex(i)
+          run_off_lic(i)   = (coeff_rel *  fqcalving(i)) + &
+               (1. - coeff_rel) * run_off_lic_0(j)
+          run_off_lic_0(j) = run_off_lic(i)
+          run_off_lic(i)   = run_off_lic(i) + fqfonte(i)/dtime
+       END DO
+    ENDIF
+    
+!****************************************************************************************
+! Save ffonte, fqfonte and fqcalving in global arrays for each 
+! sub-surface separately
+!
+!****************************************************************************************
+    DO i = 1, knon
+       ffonte_global(knindex(i),nisurf)    = ffonte(i)
+       fqfonte_global(knindex(i),nisurf)   = fqfonte(i)
+       fqcalving_global(knindex(i),nisurf) = fqcalving(i)
+    ENDDO
+
+  END SUBROUTINE fonte_neige
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_final(restart_runoff)
+!
+! This subroutine returns run_off_lic_0 for later writing to restart file.
+!
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff
+
+!****************************************************************************************
+! Set the output variables
+    restart_runoff(:) = run_off_lic_0(:)
+
+! Deallocation of all varaibles in the module
+    DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, &
+         fqfonte_global, fqcalving_global)
+
+  END SUBROUTINE fonte_neige_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, &
+       fqfonte_out, ffonte_out)
+
+! Cumulate ffonte, fqfonte and fqcalving respectively for
+! all type of surfaces according to their fraction.
+!
+! This routine is called from physiq.F before histwrite.
+
+    INCLUDE "indicesol.h"
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqcalving_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqfonte_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: ffonte_out
+
+    INTEGER   :: nisurf
+!****************************************************************************************
+
+    ffonte_out(:)    = 0.0
+    fqfonte_out(:)   = 0.0
+    fqcalving_out(:) = 0.0
+
+    DO nisurf = 1, nbsrf
+       ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf)
+    ENDDO
+
+  END SUBROUTINE fonte_neige_get_vars
+!
+!****************************************************************************************
+!
+END MODULE fonte_neige_mod
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/haut2bas.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/haut2bas.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/haut2bas.F	(revision 984)
@@ -0,0 +1,19 @@
+!
+! $Header$
+!
+      SUBROUTINE haut2bas(klon, klev, varB2H, varH2B)
+      IMPLICIT NONE
+c
+      INTEGER klon, klev
+      REAL varB2H(klon, klev), varH2B(klon, klev)
+      INTEGER i, k, kinv
+c
+      DO k=1,klev  
+       kinv=klev-k+1 
+       DO i=1,klon
+        varH2B(i,k)=varB2H(i,kinv)
+       ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/hbtm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/hbtm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/hbtm.F	(revision 984)
@@ -0,0 +1,777 @@
+!
+! $Header$
+!
+
+      SUBROUTINE HBTM(knon, paprs, pplay,
+     .                t2m,t10m,q2m,q10m,ustar,
+     .                flux_t,flux_q,u,v,t,q,
+     .                pblh,cape,EauLiq,ctei,pblT,
+     .                therm,trmb1,trmb2,trmb3,plcl)
+        USE dimphy
+        IMPLICIT none
+
+c***************************************************************
+c*                                                             *
+c* HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
+c*                 JAS 47              BLM                     *
+c* Algorithme These Anne Mathieu                               *
+c* Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+c* written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+c* features : implem. exces Mathieu                            *
+c***************************************************************
+c* mods : decembre 99 passage th a niveau plus bas. voir fixer *
+c* la prise du th a z/Lambda = -.2 (max Ray)                   *
+c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
+c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
+c* voir aussi //KE pblh = niveau The_e ou l = env.             *
+c***************************************************************
+c* fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+c***************************************************************
+c*
+c
+c
+cAM Fev 2003
+c Adaptation a LMDZ version couplee
+c
+c Pour le moment on fait passer en argument les grdeurs de surface : 
+c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms 
+c on garde la possibilite de changer si besoin est (jusqu'a present la 
+c forme de HB avec le 1er niveau modele etait conservee)
+c
+c
+c
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL RLvCp, REPS
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+cAM
+      REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+      REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+      REAL ustar(klon)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL flux_t(klon,klev), flux_q(klon,klev)     ! Flux 
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+cAM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+cAM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+cum      PARAMETER (isommet=klev) ! limite max sommet pbl
+      REAL vk
+      PARAMETER (vk=0.35)     ! Von Karman => passer a .41 ! cf U.Olgstrom
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)     ! b calcul du Prandtl et de dTetas
+      REAL fakn
+      PARAMETER (fakn=7.2)    ! a
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)  ! pour Phim / h dans la S.L stable
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)   ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+      REAL sffrac
+      PARAMETER (sffrac=0.1)  ! S.L. = z/h < .1
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL q_star,t_star
+      REAL b1,b2,b212,b2sr     ! Lambert correlations T' q' avec T* q*
+      PARAMETER (b1=70.,b2=20.)
+c
+      REAL z(klon,klev)
+cAM      REAL pcfm(klon,klev), pcfh(klon,klev)
+cAM
+      REAL zref
+      PARAMETER (zref=2.)    ! Niveau de ref a 2m peut eventuellement 
+c                              etre choisi a 10m
+cMA
+c
+      INTEGER i, k, j
+      REAL zxt
+cAM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+cAM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
+      REAL pblh(klon)
+      REAL pblT(klon)
+      REAL plcl(klon)
+cAM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+cAM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+cAM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)     ! Monin-Obukhov lengh
+cAM      REAL ztvd, ztvu, 
+      REAL zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL trmb1(klon),trmb2(klon),trmb3(klon)
+C  Algorithme thermique
+      REAL s(klon,klev)     ! [P/Po]^Kappa milieux couches
+      REAL Th_th(klon)      ! potential temperature of thermal
+      REAL The_th(klon)     ! equivalent potential temperature of thermal
+      REAL qT_th(klon)      ! total water  of thermal
+      REAL Tbef(klon)       ! T thermique niveau precedent
+      REAL qsatbef(klon)
+      LOGICAL Zsat(klon)    ! le thermique est sature
+      REAL Cape(klon)       ! Cape du thermique
+      REAL Kape(klon)       ! Cape locale
+      REAL EauLiq(klon)     ! Eau liqu integr du thermique
+      REAL ctei(klon)       ! Critere d'instab d'entrainmt des nuages de CL
+      REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat
+cIM 091204 BEG
+      REAL a1,a2,a3
+cIM 091204 END
+      REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2
+      REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the
+      REAL delt_qt,delt_2,quadsat,spblh,reduc
+c
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5
+cAM      REAL zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+
+! initialisations (Anne)
+      isommet=klev
+      th_th(:) = 0.
+      q_star = 0
+      t_star = 0
+
+
+      b212=sqrt(b1*b2)
+      b2sr=sqrt(b2)
+c
+C ============================================================
+C     Fonctions thermo implicites
+C ============================================================
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c Tetens : pression partielle de vap d'eau e_sat(T)
+c =================================================
+C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
+C++ avec :
+C++ Tf = 273.16 K  (Temp de fusion de la glace)
+C++ r2 = 611.14 Pa
+C++ r3 = 17.269 (liquide) 21.875 (solide) adim
+C++ r4 = 35.86             7.66           Kelvin
+C++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
+C++ deriv� :
+C++ =========
+C++                   r3*(Tf-r4)*q_sat(T,p)
+C++ d_qsat_dT = --------------------------------
+C++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
+c++ pour zcvm5=Lv, c'est FOEDE
+c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
+C     ------------------------------------------------------------------
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+
+c
+c      DO i = 1, klon
+c         pcfh(i,1) = cd_h(i)
+c         pcfm(i,1) = cd_m(i)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         pcfh(i,k) = zkmin
+c         pcfm(i,k) = zkmin
+c         cgs(i,k) = 0.0
+c         cgh(i,k) = 0.0
+c         cgq(i,k) = 0.0
+c      ENDDO
+c      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
+c  pourquoi ne pas utiliser Phi/RG ?
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+         s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa
+      ENDDO
+c                                 s(k) = [pplay(k)/ps]^kappa
+c    + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+c
+c    -----------------  paprs <-> sig(k)
+c
+c    + + + + + + + + + pplay  <-> s(k-1)
+c
+c
+c    + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+c
+c    -----------------  paprs <-> sig(1)
+c
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+         s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa
+      ENDDO
+      ENDDO
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++  Determination des grandeurs de surface  +++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      DO i = 1, knon
+cAM         IF (thermcep) THEN
+cAM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+c           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+c           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+cAM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+cAM           zxqs=MIN(0.5,zxqs)
+cAM           zcor=1./(1.-retv*zxqs)
+cAM           zxqs=zxqs*zcor
+cAM         ELSE
+cAM           IF (tsol(i).LT.t_coup) THEN
+cAM              zxqs = qsats(tsol(i)) / paprs(i,1)
+cAM           ELSE
+cAM              zxqs = qsatl(tsol(i)) / paprs(i,1)
+cAM           ENDIF
+cAM         ENDIF
+c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique
+cAM        zx_alf1 = 1.0
+cAM        zx_alf2 = 1.0 - zx_alf1
+cAM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .        *(1.+RETV*q(i,1))*zx_alf1
+cAM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+cAM     .        *(1.+RETV*q(i,2))*zx_alf2
+cAM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+cAM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+cAM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+cAM      
+cAMAM           zxu = u10m(i)
+cAMAM           zxv = v10m(i)
+cAMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
+cAM Niveau de ref choisi a 2m
+        zxt = t2m(i)
+
+c ***************************************************
+c attention, il doit s'agir de <w'theta'>
+c   ;Calcul de tcls virtuel et de w'theta'virtuel
+c   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+c   tcls=tcls*(1+.608*qcls)
+c
+c   ;Pour avoir w'theta',
+c   ; il faut diviser par ro.Cp
+c   Cp=Cpd*(1+0.84*qcls)
+c   fcs=fcs/(ro_surf*Cp)
+c   ;On transforme w'theta' en w'thetav'
+c   Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+c   xle=xle/(ro_surf*Lv)
+c   fcsv=fcs+.608*xle*tcls
+c ***************************************************
+cAM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+cAM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+cAM
+cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+cAM calcule de Ro = paprs(i,1)/Rd zxt
+cAM convention >0 vers le bas ds lmdz 
+        khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1))
+        kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1))
+cAM   verifier que khfs et kqfs sont bien de la forme w'l'
+        heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
+c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+cAM        heatv(i) = khfs(i)
+cAM ustar est en entree
+cAM        taux = zxu *zxmod*cd_m(i)
+cAM        tauy = zxv *zxmod*cd_m(i)
+cAM        ustar(i) = SQRT(taux**2+tauy**2)
+cAM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+c Theta et qT du thermique sans exces (interpolin vers surf)
+c chgt de niveau du thermique (jeudi 30/12/1999)
+c (interpolation lineaire avant integration phi_h)
+cAM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
+cAM        qT_th(i) = max(qT_th(i),q(i,1))
+        qT_th(i) = q2m(i)
+cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
+cn reste a regler convention P) pour Theta
+c        The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+c     -                      + RLvCp*qT_th(i)
+cAM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+        Th_th(i) = t2m(i)
+      ENDDO
+c
+      DO i = 1, knon
+         rhino(i,1) = 0.0   ! Global Richardson
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)   ! on initialise pblh a l'altitude du 1er niveau
+         plcl(i) = 6000.
+c Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+         trmb1(i)   = 0.
+         trmb2(i)   = 0.
+         trmb3(i) = 0.
+      ENDDO
+
+C
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      fac = 100.0
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
+c passer par Theta_e et virpot)
+c         zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
+cAM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i))
+c  Le Ri par Theta_v
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+cAM On a nveau de ref a 2m ???
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+c ***************************************************
+c Wm ? et W* ? c'est la formule pour z/h < .1
+c   ;Calcul de w* ;;
+c   ;;;;;;;;;;;;;;;;
+c   w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
+c   ;; CALCUL DE wm ;;
+c   ;;;;;;;;;;;;;;;;;;
+c   ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
+c   ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+c   ;;;;;;;;;;;Dans la couche de surface
+c   if (z(ind) le 20) then begin
+c   Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+c   wm=u_star/Phim
+c   ;;;;;;;;;;;En dehors de la couche de surface
+c   endif else if (z(ind) gt 20) then begin
+c   wm=(u_star^3+c1*w_star^3)^(1/3.)
+c   endif
+c ***************************************************
+        wm(i)= ustar(i)*phiminv(i)
+c======================================================================
+cvaleurs de Dominique Lambert de la campagne SEMAPHORE :
+c <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+c <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
+c et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+c avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+c(leur corellation pourrait dependre de beta par ex)
+c  if fcsv(i,j) gt 0 then begin
+c    dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+c    (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+c    2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
+c    dqs=b2*(xle(i,j)/wm(i,j))^2
+c    theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+c    q_s(i,j)=q_10(i,j)+sqrt(dqs)
+c  endif else begin
+c    Theta_s(i,j)=thetav_10(i,j)
+c    q_s(i,j)=q_10(i,j)
+c  endelse
+c======================================================================
+c
+cHBTM        therm(i) = heatv(i)*fak/wm(i)
+c forme Mathieu :
+        q_star = kqfs(i)/wm(i)
+        t_star = khfs(i)/wm(i)
+cIM 091204 BEG
+        IF(1.EQ.0) THEN
+        IF(t_star.LT.0..OR.q_star.LT.0.) THEN
+          print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star,
+     $    khfs(i),kqfs(i),wm(i)
+        ENDIF
+        ENDIF
+cIM 091204 END
+cAM Nveau cde ref 2m =>
+cAM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
+cAM     +             + (RETV*T(i,1))**2*b2*q_star**2
+cAM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
+cAM     +                 )
+cIM 091204 BEG
+        a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2
+        a2=(RETV*Th_th(i))**2*b2*q_star*q_star
+        a3=2.*RETV*Th_th(i)*b212*q_star*t_star
+        aa=a1+a2+a3
+        IF(1.EQ.0) THEN
+        IF (aa.LT.0.) THEN 
+         print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa
+         print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212',
+     $   i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212
+        ENDIF
+        ENDIF
+cIM 091204 END
+        therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     +             + (RETV*Th_th(i))**2*b2*q_star*q_star
+cIM 101204  +             + 2.*RETV*Th_th(i)*b212*q_star*t_star
+     +             + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star)
+     +                 )
+c
+c Theta et qT du thermique (forme H&B) avec exces
+c (attention, on ajoute therm(i) qui est virtuelle ...)
+c pourquoi pas sqrt(b1)*t_star ?
+c        dqs = b2sr*kqfs(i)/wm(i)
+        qT_th(i) = qT_th(i)  + b2sr*q_star
+cnew on differre le calcul de Theta_e
+c        The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+        rhino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++ Improve pblh estimate for unstable conditions using the +++++++
+C ++          convective temperature excess :                +++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c et therm Theta_v (avec hypothese de constance de H&B,
+c         zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i)
+
+c
+c  Le Ri par Theta_v
+cAM Niveau de ref 2m
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+cIM 170305 BEG
+      IF(1.EQ.0) THEN
+c debug print -120;34       -34-        58 et    0;26 wamp
+      if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then
+            print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i)
+            q_star = kqfs(i)/wm(i)
+            t_star = khfs(i)/wm(i)
+            print*,'q* t*, b1,b2,b212 ',q_star,t_star
+     -            , b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     -            , (RETV*Th_th(i))**2*b2*q_star**2
+     -            , 2.*RETV*Th_th(i)*b212*q_star*t_star
+            print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2
+      endif
+      ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+c             q_star = kqfs(i)/wm(i)
+c             t_star = khfs(i)/wm(i)
+c             trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
+c             trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
+c Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+c par exemple :
+        pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
+     .              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+      ENDDO
+
+C ********************************************************************
+C  pblh is now available; do preparation for diffusivity calculation :
+C ********************************************************************
+      DO i = 1, knon
+        check(i) = .TRUE.
+        Zsat(i)   = .FALSE.
+c omegafl utilise pour prolongement CAPE
+        omegafl(i) = .FALSE.
+        Cape(i)   = 0.
+        Kape(i)   = 0.
+        EauLiq(i) = 0.
+        CTEI(i)   = 0.
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C *** Rq: les formule sont prises dans leur forme CS ***
+        IF (unstbl(i)) THEN
+cAM Niveau de ref du thermique
+cAM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .         *(1.+RETV*q(i,1))
+          zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i)))
+     .         *(1.+RETV*qT_th(i))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+c Computes Theta_e for thermal (all cases : to be modified)
+c   attention ajout therm(i) = virtuelle
+        The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+C debug
+c          if (i.EQ.1864) then
+c             print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
+c          endif
+
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+c        print*,'fin calcul niveaux'
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms zero'
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+c            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+c            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+c            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms non zero'
+C
+C For all unstable layers, compute diffusivities and ctrgrad ter m
+C
+c        DO i = 1, knon
+c        IF (unslev(i)) THEN
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pblk(i)/pr(i)
+c etc cf original
+c        ENDIF
+c        ENDDO
+C
+C For all layers, compute integral info and CTEI
+C
+        DO i = 1, knon
+        if (check(i).or.omegafl(i)) then
+          if (.not.Zsat(i)) then
+c            Th2 = The_th(i) - RLvCp*qT_th(i)
+            Th2 = Th_th(i)
+            T2 = Th2*s(i,k)
+c thermodyn functions
+            zdelta=MAX(0.,SIGN(1.,RTT-T2))
+            qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k)
+            qqsat=MIN(0.5,qqsat)
+            zcor=1./(1.-retv*qqsat)
+            qqsat=qqsat*zcor
+c
+            if (qqsat.lt.qT_th(i)) then
+c on calcule lcl
+              if (k.eq.2) then
+                plcl(i) = z(i,k)
+              else
+                plcl(i) =  z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .                 (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat)
+              endif
+              Zsat(i) = .true.
+              Tbef(i) = T2
+            endif
+c
+          endif
+          qsatbef(i) = qqsat
+camn ???? cette ligne a deja ete faite normalement ?
+        endif
+c            print*,'hbtm2 i,k=',i,k
+        ENDDO
+ 1000 continue           ! end of level loop
+cIM 170305 BEG
+        IF(1.EQ.0) THEN
+            print*,'hbtm2  ok'
+        ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/hgardfou.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/hgardfou.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/hgardfou.F	(revision 984)
@@ -0,0 +1,127 @@
+!
+! $Header$
+!
+      SUBROUTINE hgardfou (t,tsol,text)
+      use dimphy
+      use phys_state_var_mod
+      IMPLICIT none
+c======================================================================
+c Verifier la temperature
+c======================================================================
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+      REAL t(klon,klev), tsol(klon,nbsrf)
+      CHARACTER*(*) text
+C
+      INTEGER i, k, nsrf
+      REAL zt(klon)
+      INTEGER jadrs(klon), jbad
+      LOGICAL ok
+c
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall /.TRUE./
+      IF (firstcall) THEN
+         PRINT*, 'hgardfou garantit la temperature dans [100,370] K'
+         firstcall = .FALSE.
+c        DO i = 1, klon
+c         print*,'i=',i,'rlon=',rlon(i),'rlat=',rlat(i)
+c        ENDDO
+c
+      ENDIF
+c
+      ok = .TRUE.
+      DO k = 1, klev
+         DO i = 1, klon
+            zt(i) = t(i,k)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+            PRINT *,'i,k,temperature rlon rlat=',jadrs(i),k,zt(jadrs(i))
+     $      ,rlon(jadrs(i)),rlat(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+            PRINT *,'i,k,temperature rlon rlat=',jadrs(i),k,zt(jadrs(i))
+     $      ,rlon(jadrs(i)),rlat(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+         DO i = 1, klon
+            zt(i) = tsol(i,nsrf)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i)),
+     $       rlon(jadrs(i)),rlat(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i)),
+     $       rlon(jadrs(i)),rlat(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      IF (.NOT. ok) THEN
+         PRINT*, 'hgardfou s arrete ', text
+         CALL abort
+      ENDIF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/histo_o500_pctau.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/histo_o500_pctau.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/histo_o500_pctau.F	(revision 984)
@@ -0,0 +1,67 @@
+!
+! $Header$
+!
+      SUBROUTINE histo_o500_pctau(nbreg,pct_ocean,w,histo,histoW,nhisto)
+      USE dimphy
+      IMPLICIT none
+
+      INTEGER :: ij, k, l, nw
+      INTEGER :: nreg, nbreg
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      INTEGER, PARAMETER :: kmax=8, lmax=8
+      INTEGER, PARAMETER :: kmaxm1=kmax-1, lmaxm1=lmax-1
+      INTEGER, PARAMETER :: iwmax=40
+
+      INTEGER, dimension(klon) :: iw
+      REAL, dimension(klon) :: w
+      REAL, PARAMETER :: wmin=-200., pas_w=10.
+      REAL, dimension(kmaxm1,lmaxm1,iwmax,nbreg) :: histoW, nhisto
+      REAL, dimension(klon,kmaxm1,lmaxm1) :: histo
+
+!     LOGICAL, dimension(klon,nbreg) :: pct_ocean
+      INTEGER, dimension(klon,nbreg) :: pct_ocean
+
+! initialisation
+      histoW(:,:,:,:)=0.      
+      nhisto(:,:,:,:)=0.   
+!   
+!calcul de l'histogramme de chaque regime dynamique
+      DO nreg=1, nbreg
+       DO ij=1, klon
+        iw(ij) = int((w(ij)-wmin)/pas_w) +1
+c       IF(pct_ocean(ij,nreg)) THEN
+c       IF(pct_ocean(ij,nreg).EQ.1) THEN
+         IF(iw(ij).GE.1.AND.iw(ij).LE.iwmax) THEN 
+          DO l=1, lmaxm1
+           DO k=1, kmaxm1
+            IF(histo(ij,k,l).GT.0.) THEN
+             histoW(k,l,iw(ij),nreg) = histoW(k,l,iw(ij),nreg) 
+     &       + histo(ij,k,l)*pct_ocean(ij,nreg)
+             nhisto(k,l,iw(ij),nreg)= nhisto(k,l,iw(ij),nreg) + 
+     &       pct_ocean(ij,nreg)
+            ENDIF
+           ENDDO !k
+          ENDDO !l
+c        ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw
+c         PRINT*,'ij,iw=',ij,iw(ij)
+         ENDIF !iw
+c       ENDIF !pct_ocean
+       ENDDO !ij
+!normalisation
+       DO nw=1, iwmax
+        DO l=1, lmaxm1
+         DO k=1, kmaxm1
+          IF(nhisto(k,l,nw,nreg).NE.0.) THEN
+           histoW(k,l,nw,nreg) = 100.*histoW(k,l,nw,nreg)
+     &     /nhisto(k,l,nw,nreg)
+c          PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg,
+c    &     histoW(k,l,nw,nreg)
+          ENDIF
+         ENDDO !k
+        ENDDO !l
+       ENDDO !nw
+      ENDDO !nreg
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/homogene.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/homogene.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/homogene.F	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE homogene(paprs, q, dq, u,v, du, dv)
+      USE dimphy
+      IMPLICIT NONE
+c==============================================================
+c Schema ad hoc du melange vertical pour les vitesses u et v,
+c a appliquer apres le schema de convection (fiajc et fiajh).
+c
+c paprs:input, pression demi-couche (inter-couche)
+c q:    input, vapeur d'eau (kg/kg)
+c dq:   input, incrementation de vapeur d'eau (de la convection)
+c u:    input, vitesse u
+c v:    input, vitesse v
+c
+c du:   output, incrementation pour u
+c dv:   output, incrementation pour v
+c==============================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      REAL paprs(klon,klev+1)
+      REAL q(klon,klev), dq(klon,klev)
+      REAL u(klon,klev), du(klon,klev)
+      REAL v(klon,klev), dv(klon,klev)
+c
+      REAL zm_dq(klon) ! quantite totale de l'eau deplacee
+      REAL zm_q(klon)  ! quantite totale de la vapeur d'eau
+      REAL zm_u(klon)  ! moyenne de u (brassage parfait et total)
+      REAL zm_v(klon)  ! moyenne de v (brassage parfait et total)
+      REAL z_frac(klon) ! fraction du brassage parfait et total
+      REAL zm_dp(klon)
+c
+      REAL zx
+      INTEGER i, k
+      REAL frac_max
+      PARAMETER (frac_max=0.1)
+      REAL seuil
+      PARAMETER (seuil=1.0e-10)
+      LOGICAL faisrien
+      PARAMETER (faisrien=.true.)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         du(i,k) = 0.0
+         dv(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      IF (faisrien) RETURN
+c
+      DO i = 1, klon
+         zm_dq(i)=0.
+         zm_q(i) =0.
+         zm_u(i)=0.
+         zm_v(i)=0.
+         zm_dp(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (ABS(dq(i,k)).GT.seuil) THEN
+         zx = paprs(i,k) - paprs(i,k+1)
+         zm_dq(i) = zm_dq(i) + ABS(dq(i,k))*zx
+         zm_q(i) = zm_q(i) + q(i,k)*zx
+         zm_dp(i) = zm_dp(i) + zx
+         zm_u(i) = zm_u(i) + u(i,k)*zx
+         zm_v(i) = zm_v(i) + v(i,k)*zx
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Hypothese principale: apres la convection, la vitesse de chaque
+c couche est composee de deux parties: celle (1-z_frac) de la vitesse 
+c original et celle (z_frac) de la vitesse moyenne qui serait la
+c vitesse de chaque couche si le brassage etait parfait et total.
+c La fraction du brassage est calculee par le rapport entre la quantite
+c totale de la vapeur d'eau deplacee (ou condensee) et la quantite
+c totale de la vapeur d'eau. Et cette fraction est limitee a frac_max 
+c (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995).
+c
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.0E-15 .AND. zm_q(i).GE.1.0E-15) THEN
+         z_frac(i)=MIN(frac_max,zm_dq(i)/zm_q(i))
+         zm_u(i)=zm_u(i)/zm_dp(i)
+         zm_v(i)=zm_v(i)/zm_dp(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.e-15 .AND. zm_q(i).GE.1.e-15
+     .                         .AND. ABS(dq(i,k)).GT.seuil) THEN
+         du(i,k) = u(i,k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i,k)
+         dv(i,k) = v(i,k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/hydrol.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/hydrol.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/hydrol.F	(revision 984)
@@ -0,0 +1,121 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap,
+     .                  agesno, tsol,qsol,snow,runoff)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940414
+c======================================================================
+c
+c Traitement de l'hydrologie du sol
+c ---------------------------------
+c rain_fall: taux de pluie
+c snow_fall: taux de neige
+c agesno: age de la neige
+c evap: taux d'evaporation
+c tsol: temperature du sol
+c qsol: humidite du sol
+c snow: couverture neigeuse
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c
+      REAL chasno ! epaisseur du sol: 0.15 m
+      PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15))
+      REAL mx_eau_sol
+      PARAMETER (mx_eau_sol=150.0)
+c
+      REAL dtime
+      REAL pctsrf(klon,nbsrf)
+      REAL snow(klon,nbsrf), tsol(klon,nbsrf), qsol(klon,nbsrf)
+      REAL snow_fall(klon), rain_fall(klon), evap(klon)
+      REAL runoff(klon), agesno(klon)
+C
+      INTEGER i, is
+      REAL subli, fsno
+C-----------------------------------------------------------------------
+      DO 99999 i = 1, klon
+c
+         runoff(i) = 0.0
+c
+         is = is_ter
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_lic
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+cIM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+cIM cf GK : la glace fond a 0C, non pas a -1.8
+            tsol(i,is) = MIN(tsol(i,is),RTT)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_sic
+         qsol(i,is) = 0.0
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+cIM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+cIM cf GK : la glace fond a 0C, non pas a -1.8
+            tsol(i,is) = MIN(tsol(i,is),RTT)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         agesno(i) = (agesno(i)+ (1.-agesno(i)/50.)*dtime/86400.)
+     .             * EXP(-1.*MAX(0.0,snow_fall(i))*dtime/0.3)
+         agesno(i) = MAX(agesno(i),0.0)
+c
+99999 CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/indicesol.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/indicesol.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/indicesol.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+!
+      INTEGER is_oce
+      PARAMETER (is_oce=3) ! ocean
+      INTEGER is_sic
+      PARAMETER (is_sic=4) ! glace de mer
+      INTEGER is_ter
+      PARAMETER (is_ter=1) ! terre
+      INTEGER is_lic
+      PARAMETER (is_lic=2) ! glacier continental
+!
+      REAL epsfra
+      PARAMETER (epsfra=1.0E-05)
+!
+      CHARACTER *3 clnsurf(nbsrf)
+      DATA clnsurf/'ter', 'lic', 'oce', 'sic'/
+      SAVE clnsurf
+!$OMP THREADPRIVATE(clnsurf)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_bilKP_ave.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_bilKP_ave.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_bilKP_ave.h	(revision 984)
@@ -0,0 +1,259 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+         zsto = dtime
+         zout = ecrit_day
+         typeval=tave
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         write(*,*)'zx_lon = ',zx_lon(:,1)
+cym         write(*,*)'zx_lat = ',zx_lat(1,:)
+cym         CALL histbeg("histbilKP_ave", iim,zx_lon(:,1), jjmp1,
+cym     .                zx_lat(1,:),
+cym     .                1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                nhori, nid_bilKPave)
+         CALL histbeg_phy("histbilKP_ave", itau_phy, zjulian, dtime,
+     .                nhori, nid_bilKPave)
+
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_bilKPave, "presnivs",
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPave,"ue",
+     .   "Zonal energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"ve",
+     .   "Merid energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"uq",
+     .   "Zonal humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vq",
+     .   "Merid humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPave,"temp",
+     .   "Air temperature","K",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"ovap",
+     .   "Specific humidity","Kg/Kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"geop",
+     .   "Geopotential height","m",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vitu",
+     .   "Zonal wind","m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vitv",
+     .   "Meridional wind","m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "vitw", 
+     .   "Vertical wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "pres", 
+     .   "Inter-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "play", 
+     .   "Mean-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "oliq", 
+     .   "Liquid water content", 
+     .                "kg/kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtdyn", 
+     .   "Dynamics dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqdyn", 
+     .   "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtcon", 
+     .   "Convection dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "ducon", 
+     .   "Convection du", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dvcon", 
+     .   "Convection dv", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqcon",
+     .   "Convection dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlsc", 
+     .   "Condensation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqlsc",
+     .   "Condensation dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dtvdf",
+     .   "Boundary-layer dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqvdf", 
+     .   "Boundary-layer dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dtajs",
+     .   "Ajustement sec dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqajs",
+     .   "Ajustement sec dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dteva", 
+     .   "Reevaporation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqeva",
+     .   "Reevaporation dQ",
+     .                "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+
+c
+         CALL histdef(nid_bilKPave, "dtswr", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtsw0", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlwr", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlw0", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"duvdf",
+     .   "Boundary-layer dU","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dvvdf",
+     .   "Boundary-layer dV","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         IF (ok_orodr) THEN
+         IF (ok_orolf) THEN
+         CALL histdef(nid_bilKPave, "duoli",
+     .   "Orography dU", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dvoli", 
+     .   "Orography dV", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF
+         ENDIF
+C
+         CALL histdef(nid_bilKPave, "duphy",
+     .   "Physiq dU","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dvphy",
+     .   "Physiq dV","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dtphy",
+     .   "Physiq dT","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dqphy",
+     .   "Physiq dQ","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dqlphy",
+     .   "Physiq dQl","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+C
+         CALL histend(nid_bilKPave)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_bilKP_ins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_bilKP_ins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_bilKP_ins.h	(revision 984)
@@ -0,0 +1,326 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+         zsto = dtime
+         zout = dtime
+         typeval=tinst
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         write(*,*)'zx_lon = ',zx_lon(:,1)
+cym         write(*,*)'zx_lat = ',zx_lat(1,:)
+c
+cIM 280405 BEG
+c
+cIM cf. AM 081204 BEG region
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+cym          do i=1,iim-1
+cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+cym          enddo
+cym          do j=1,jjmp1
+cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+cym          enddo
+c
+          print*,'On stoke le fichier bilKP instantanne sur ',
+     s   imin_ins,imax_ins,jmin_ins,jmax_ins
+          print*,'On stoke le fichier bilKP instantanne sur ',
+     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+cIM cf. AM 081204 END region
+c
+cIM 280405 END
+c
+cym         IF(1.EQ.0) THEN
+cym         CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), jjmp1,
+cym     .                zx_lat(1,:),
+cym     .                1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                nhori, nid_bilKPins)
+         ENDIF
+c
+cIM 280405 BEG
+c
+cIM cf. AM 081204 BEG region
+cym         CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), 
+cym     .                 jjmp1,zx_lat(1,:),
+cym     .                 imin_ins,imax_ins-imin_ins+1,
+cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_bilKPins)
+         CALL histbeg_phy("histbilKP_ins", itau_phy, zjulian, dtime,
+     .                 nhori, nid_bilKPins)
+cIM 081204 END
+c
+cIM 280405 END
+c
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_bilKPins, "presnivs",
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPins,"ue",
+     .   "Zonal energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"ve",
+     .   "Merid energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"uq",
+     .   "Zonal humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vq",
+     .   "Merid humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPins, "temp",
+     .   "Air temperature", "K",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"ovap",
+     .   "Specific humidity","Kg/Kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"geop",
+     .   "Geopotential height", "m",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vitu", 
+     .   "Zonal wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vitv", 
+     .   "Meridional wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "vitw",
+     .   "Vertical wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "pres",
+     .   "Inter-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "play",
+     .   "Mean-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "oliq",
+     .   "Liquid water content", 
+     .                "kg/kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtdyn",
+     .   "Dynamics dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dqdyn",
+     .   "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtcon",
+     .   "Convection dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "ducon",
+     .   "Convection du", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dvcon",
+     .   "Convection dv", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqcon",
+     .   "Convection dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlsc",
+     .   "Condensation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqlsc",
+     .   "Condensation dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dtvdf",
+     .   "Boundary-layer dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dqvdf", 
+     .   "Boundary-layer dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dtajs",
+     .   "Ajustement sec dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqajs",
+     .   "Ajustement sec dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dteva",
+     .   "Reevaporation dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqeva",
+     .   "Reevaporation dQ",
+     .                "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+
+c
+         CALL histdef(nid_bilKPins, "dtswr", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtsw0", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlwr", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlw0", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"duvdf",
+     .   "Boundary-layer dU","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dvvdf",
+     .   "Boundary-layer dV","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         IF (ok_orodr) THEN
+         IF (ok_orolf) THEN
+         CALL histdef(nid_bilKPins, "duoli", 
+     .   "Orography dU", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dvoli", 
+     .   "Orography dV", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF
+         ENDIF
+C
+         CALL histdef(nid_bilKPins, "duphy",
+     .   "Physiq dU","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dvphy",
+     .   "Physiq dV","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dtphy",
+     .   "Physiq dT","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dqphy",
+     .   "Physiq dQ","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dqlphy",
+     .   "Physiq dQl","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+cIM 280405 BEG
+c
+c Champs 2D:
+c
+c u850, v850
+c        DO k=1, nlevSTD
+         DO k=1, 12
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+         IF(bb2.EQ."850") THEN 
+c
+          CALL histdef(nid_bilKPins, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jjphy_nb,nhori, 1,1,1, -99, 32,
+     .                typeval, zsto,zout)
+c
+          CALL histdef(nid_bilKPins, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jjphy_nb,nhori, 1,1,1, -99, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF !(bb2.EQ."850") 
+c
+         ENDDO !k=1, 12
+c
+cIM 280405 END
+c
+         CALL histend(nid_bilKPins)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_coord_REGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_coord_REGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_coord_REGDYN.h	(revision 984)
@@ -0,0 +1,81 @@
+c
+c $Header$
+c
+       nsrf=3
+       DO nreg=1, nbregdyn
+       DO i=1, klon
+
+c       IF (debut) THEN
+         IF(rlon(i).LT.0.) THEN
+           rlonPOS(i)=rlon(i)+360.
+         ELSE
+           rlonPOS(i)=rlon(i)  
+         ENDIF
+c       ENDIF
+
+        pct_ocean(i,nreg)=0
+
+c test si c'est 1 point d'ocean
+        IF(pctsrf(i,nsrf).EQ.1.) THEN
+
+         IF(nreg.EQ.1) THEN
+
+c TROP
+          IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+
+c PACIFIQUE NORD
+          ELSEIF(nreg.EQ.2) THEN
+           IF(rlat(i).GE.40.AND.rlat(i).LE.60.) THEN
+            IF(rlonPOS(i).GE.160..AND.rlonPOS(i).LE.235.) THEN 
+             pct_ocean(i,nreg)=1
+            ENDIF
+           ENDIF
+c CALIFORNIE ST-CU
+         ELSEIF(nreg.EQ.3) THEN
+          IF(rlonPOS(i).GE.220..AND.rlonPOS(i).LE.250.) THEN
+           IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN
+            pct_ocean(i,nreg)=1
+           ENDIF
+          ENDIF
+c HAWAI
+        ELSEIF(nreg.EQ.4) THEN 
+         IF(rlonPOS(i).GE.180..AND.rlonPOS(i).LE.220.) THEN
+          IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+         ENDIF
+c WARM POOL
+        ELSEIF(nreg.EQ.5) THEN 
+         IF(rlonPOS(i).GE.70..AND.rlonPOS(i).LE.150.) THEN
+          IF(rlat(i).GE.-5.AND.rlat(i).LE.20.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+         ENDIF
+        ENDIF !nbregdyn
+c TROP
+c        IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN
+c         pct_ocean(i)=.TRUE.
+c         WRITE(*,*) 'pct_ocean =',i, rlon(i), rlat(i)
+c          ENDIF !lon
+c         ENDIF !lat
+
+        ENDIF !pctsrf
+       ENDDO !klon
+       ENDDO !nbregdyn
+cIM 190504      ENDIF !ok_regdyn
+ 
+cIM somme de toutes les nhistoW BEG
+      IF (debut) THEN
+      DO nreg = 1, nbregdyn
+       DO k = 1, kmaxm1
+        DO l = 1, lmaxm1
+         DO iw = 1, iwmax
+          nhistoWt(k,l,iw,nreg)=0.
+         ENDDO !iw
+        ENDDO !l
+       ENDDO !k
+      ENDDO !nreg
+      ENDIF !(debut) THEN
+cIM 190504 BEG
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histISCCP.h	(revision 984)
@@ -0,0 +1,267 @@
+!
+! $Header$
+!
+      IF (ok_isccp) THEN
+c
+c$OMP MASTER
+      ndex2d = 0
+      ndex3d = 0
+c
+c pour les champs instantannes, il faut mettre la meme valeur pour
+c zout et zsto.
+c dtime est passe par ailleurs a histbeg
+c zstophy = frequence de stockage des champs tous les pdt physiques
+c zout = frequence d'ecriture des champs
+cIM 300505     zstophy = dtime 
+c appel du simulateur toutes les 3heures
+!IM on lit la frequence d'appel dans physiq.def
+!         zcals(1) = dtime *6.  !toutes les 3h (en s)
+          zcals(1) = freq_ISCCP !toutes les freq_ISCCP secondes
+        DO n=1, napisccp
+          zcalh(n) = zcals(n)/3600. !stoutes les Xh (en heures)
+        ENDDO !n
+c
+c ecriture 8 fois par jour
+c       zout = dtime * REAL(NINT(86400./dtime*ecrit_isccp))
+c ecriture toutes les 2h (12 fois par jour)
+c       zout = dtime * 4.
+c ecriture toutes les 1/2 h (48 fois par jour)
+c       zout = dtime
+c
+c       IF(freqout_isccp.EQ.1.) THEN
+c ecriture jounaliere
+!IM on ecrit les resultats du simulateur ISCCP toutes les 
+! ecrit_ISCCP secondes      zout_isccp(1) = ecrit_day !(en s)
+          zout_isccp(1) = ecrit_ISCCP !(en s)
+c ecriture mensuelle
+c         zout = dtime * ecrit_mth !(en s)
+        DO n=1, napisccp 
+          zoutj(n)=zout_isccp(n)/86400. !(en jours)
+c
+c le nombre de sous-colonnes ncol : ncol=(100.*zcalh)/zoutd
+          ncol(n)=NINT((100.*zcalh(n))/zoutj(n))
+          IF(ncol(n).GT.ncolmx) THEN
+           PRINT*,'Warning: Augmenter le nombre colonnes du simulateur'
+           PRINT*,'         ISCCP ncol=', ncol,' ncolmx=',ncolmx
+c          PRINT*,'n ncol',n,ncol(n)
+           CALL abort
+          ENDIF
+c
+        DO l=1, ncol(n)
+          vertlev(l,n)=float(l)
+        ENDDO !ncol
+c
+        ENDDO !n
+
+c       PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp
+c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c       write(*,*)'ISCCP ', itau_phy, zjulian
+c
+c
+c definition coordonnees lon,lat en globale
+c
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym        DO i = 1, iim
+cym          zx_lon(i,1) = rlon(i+1)
+cym          zx_lon(i,jjmp1) = rlon(i+1)
+cym        ENDDO
+
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+cIM BEG region
+cym Desole dans un premier temps le mode region ne marchera pas
+cym Il faudra voir dans un second temps pour l'implementer
+cym Mais cela posera des problemes au niveau de la reconstruction
+
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+cym          do i=1,iim-1
+cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+cym          enddo
+cym          do j=1,jjmp1
+cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+cym          enddo
+c
+          print*,'On stoke le fichier histISCCP sur ',
+     s   imin_ins,imax_ins,jmin_ins,jmax_ins
+cym          print*,'On stoke le fichier histISCCP instantanne sur ',
+cym     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+cym     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+cIM END region
+c
+        IF(1.EQ.0) THEN
+cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:),
+cym     .                 1, iim, 1, jjmp1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_isccp)
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,
+     .                 nhori, nid_isccp)
+        ENDIF !(1.EQ.0) THEN
+c
+cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),
+cym     .                 jjmp1,zx_lat(1,:),
+cym     .                 imin_ins,imax_ins-imin_ins+1,
+cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_isccp)
+
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,
+     .                 nhori, nid_isccp)
+c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+         CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb",
+     .                 lmaxm1, cldtopres, nvert,'down')
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+         CALL histvert(nid_isccp,"cldtopres3","Cloud Top Pressure","mb",
+     .                 lmax3, cldtopres3, nvert3,'down')
+        ENDIF
+        DO n=1, napisccp
+         CALL histvert(nid_isccp, "Nbcol"//verticaxe(n),
+     .        "Nb of Column"//verticaxe(n),"1",
+     .        ncol(n), vertlev(:,n), nvlev(n),'up')
+        ENDDO
+c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+c variables a ecrire
+c 
+         DO n=1, napisccp
+c
+         DO k=1, kmaxm1
+          CALL histdef(nid_isccp, "cldISCCP_"//taulev(k)//verticaxe(n),
+     .                "LMDZ ISCCP cld", "%",
+     .                iim, jj_nb,nhori,lmaxm1,1,lmaxm1,nvert,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+         ENDDO
+c
+         CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),
+     .                "Nb of calls with sunlit ", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+         ENDDO
+c
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+         DO n=1, napisccp
+c
+c         print*,'n=',n,' avant histdef(..LMDZ ISCCP cld'
+c
+          DO k=1, kmaxm1
+           DO l=1, lmaxm1
+c
+           CALL histdef(nid_isccp, pclev(l)//taulev(k)//verticaxe(n),
+     .                "LMDZ ISCCP cld "//cnameisccp(l,k), "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+           ENDDO
+          ENDDO
+c
+c         print*,'n=',n,' avant histdef(..Nb of calls sunlit'
+          CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),
+     .                "Nb of calls with sunlit ", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c 9types de nuages ISCCP-D2
+          CALL histdef(nid_isccp, "cirr",
+     .                "Cirrus lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "cist",
+     .                "CiSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "deep",
+     .                "Deep lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "alcu",
+     .                "AlCu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "alst",
+     .                "AlSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "nist",
+     .                "NiSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "cumu",
+     .                "Cumu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "stcu",
+     .                "StCu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "stra",
+     .                "Stra lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c 3_epaisseurs_optiques x3_pressions_au_sommet_des_nuages  types de nuages 
+          CALL histdef(nid_isccp, "thin",
+     .                "Opt. thin ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "mid",
+     .                "Opt. intermediate ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "thick",
+     .                "Opt. thick ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c        IF(1.EQ.0) THEN
+c        IF(n.EQ.3) THEN
+c        IF(n.EQ.1) THEN
+c
+cIM 070905 BEG
+         IF(1.EQ.0) THEN
+          print*,'n=',n,' avant histdef(..boxptop axe'
+cIM verif boxptop
+          CALL histdef(nid_isccp,"boxptop"//verticaxe(n),
+     .                "Boxptop axe"//verticaxe(n), "mb",
+     .                iim, jj_nb,nhori,
+     .                ncol(n),1,ncol(n),nvlev(n),32,
+cIM  .                ncolmx,1,ncolmx,nvlev,32,
+cIM  .                "inst(X)",dtime,dtime)
+     .                "ave(X)",zcals(n),zout_isccp(n))
+         ENDIF !(1.EQ.0) THEN
+cIM 070905 END
+c        ENDIF !(n.EQ.3) THEN
+c       ENDIF !(1.EQ.0) THEN
+c
+c         print*,'n=',n,' avant histdef(..seed axe'
+          CALL histdef(nid_isccp, "seed"//verticaxe(n),
+     .                "seed axe"//verticaxe(n), "-",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+cIM  .                "inst(X)", dtime,dtime)
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+         ENDDO !n
+        ENDIF 
+        CALL histend(nid_isccp)
+c
+c$OMP END MASTER
+      ENDIF ! ok_isccp
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histREGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histREGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histREGDYN.h	(revision 984)
@@ -0,0 +1,127 @@
+!
+! $Header$
+!
+
+      IF (ok_regdyn) THEN
+      
+        if (is_sequential) then
+c
+cIM      PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_mth
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+c axe vertical pour les differents niveaux des histogrammes
+      DO iw=1, iwmax
+        zx_o500(iw)=wmin+(iw-1./2.)*pas_w
+      ENDDO
+
+         CALL histbeg("histREGDYN", kmaxm1,zx_tau, lmaxm1,zx_pc,
+     .                 1,kmaxm1,1,lmaxm1, itau_phy, zjulian, dtime, 
+     .                 nhoriRD, nid_regdyn)
+
+         CALL histvert(nid_regdyn, "omeganivs", "Omega levels", 
+     .                 "mb/day",
+     .                 iwmax, zx_o500, komega)
+c
+c   pour les champs instantannes, il faut mettre la meme valeur pour
+c   zout et zsto.
+c   dtime est passe par ailleurs a histbeg
+c
+c        zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn))
+c        zsto = zout
+c        print*,'zout,zsto=',zout,zsto
+c
+c stockage a chaque pas de temps de la physique
+c
+         zstophy = dtime
+cIM 020904      zstophy = dtime * nbapp_isccp
+
+c ecriture mensuelle
+c
+         zout = dtime * ecrit_mth
+cIM 020904      
+c        zout = dtime * ecrit_day
+c        zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn))
+
+c
+c Champs 3D:
+c
+c TROP
+         CALL histdef(nid_regdyn, "hw1", "Tropics Histogram ", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh1", "Nb of pixels Tropics Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht1",
+     &                "Total Nb pixels Tropics Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+c PAN
+         CALL histdef(nid_regdyn, "hw2", "North Pacific Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh2", "Nb of pixels North Pacific",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht2",
+     &                "Total Nb pixels North Pacific Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c CAL
+         CALL histdef(nid_regdyn, "hw3", "California Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh3", 
+     &                "Nb of pixels California Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht3",
+     &                "Total Nb pixels California Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c HAW
+         CALL histdef(nid_regdyn, "hw4", "Hawai Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh4", "Nb of pixels Hawai Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht4",
+     &                "Total Nb pixels Hawai Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c WAP
+         CALL histdef(nid_regdyn, "hw5", "Warm Pool Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh5", "Nb of pixels Warm Pool Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht5",
+     &                "Total Nb pixels Warm Pool Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+         CALL histend(nid_regdyn)
+	 
+	 endif ! is_sequential
+
+      endif ! ok_regdyn
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histday.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histday.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histday.h	(revision 984)
@@ -0,0 +1,738 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+
+c$OMP MASTER
+c
+       zstophy = dtime
+       zstoday= ecrit_day
+       zout = ecrit_day
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_day)
+
+         CALL histbeg_phy("histday",itau_phy, zjulian, dtime, 
+     .                    nhori, nid_day)
+
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+       IF(lev_histday.GE.1) THEN
+c
+         CALL histdef(nid_day, "phis", "Surface geop. height", "m2/s2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "contfracATM","% sfce ter+lic ","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "contfracOR","% sfce terre OR", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_day, "weakinv", "Weak inversion", "",
+     s           iim,jjmp1,nhori, 1,1,1, -99, 32,
+     s           "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "dthmin", "dTheta mini", "K/m",
+     s           iim,jjmp1,nhori, 1,1,1, -99, 32,
+     s           "ave(X)", zstophy,zout)
+
+
+         CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c Champs retires momentannement en attendant un hypothetique
+c debugage
+
+         CALL histdef(nid_day, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_day, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+!        CALL histdef(nid_day, "plul", "Large-scale Precip.",
+!    .   "kg/(s*m2)",
+!    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+!    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "pluc", "Convective Precip.",
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "snowl", "Solid Large-scale Precip.",
+     .   "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF(1.EQ.0) THEN !snowc=0.
+         CALL histdef(nid_day, "snowc", "Solid Convective Precip.",
+     .   "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF !snowc=0.
+c
+         CALL histdef(nid_day, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstoday,zout)
+c
+         CALL histdef(nid_day, "q2m", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wind10max", "10-m wind speed max.",
+     .                "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "precip","Precipitation Totale liq+sol"
+     .                , "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "plul","Precipitation ls liq+sol"
+     .                , "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "snowf", "Snow fall", "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_day, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "evap", "Evaporation", "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sols", "Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldq", "Cloud liquid water path", 
+     .                "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c  Champs dynamiques sur niveaux de pression
+c
+c        DO k=1, nlevENS
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb2=clevSTD(k)
+c        ENDIF
+c
+         IF(bb2.EQ."850".OR.bb2.EQ."700"
+     .   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_day, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_day, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+         IF(bb2.EQ."500") THEN
+c
+         CALL histdef(nid_day, "w"//bb2, "Vertical wind "//bb2//"mb",
+     .                "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_day,"phi"//bb2, "Geopotential "//bb2//"mb",
+     .                "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."500")
+c
+         ENDDO !nlevSTD
+c
+         CALL histdef(nid_day, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cape_max", "CAPE max.",
+     .                "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                capemaxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+         IF (OCEAN.EQ.'force ') THEN
+c
+          CALL histdef(nid_day, "lmt_bils", 
+     .         "Bilan au sol atmosphere forcee", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+          CALL histdef(nid_day, "slab_bils",
+     .                "Bilan au sol slab", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "tslab", "Slab SST ", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "seaice", "Slab seaice", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "siceh", "Slab seaice height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF !OCEAN.EQ.force/slab
+c
+         CALL histdef(nid_day, "fluxo",
+     .                "Flux turbulents ocean-atmosphere", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "fluxg",
+     .                "Flux ocean-glace de mer", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.1
+c
+      IF (lev_histday.GE.2) THEN
+c
+         CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2/K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.2
+c=================================================================
+      IF(lev_histday.GE.3) THEN
+c=================================================================
+c   INITIALISATION DES CHAMPS 3D
+c=================================================================
+c=================================================================
+c=================================================================
+c Champs 3D:
+c
+         CALL histdef(nid_day, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rhum", "relative humidity", " ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c=================================================================
+c   FIN INITIALISATION DES CHAMPS 3D
+c=================================================================
+      ENDIF !  lev_histday.GE.3
+c
+      IF (lev_histday.GE.4) THEN
+c=================================================================
+c
+c   INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+c
+         CALL histdef(nid_day, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWupTOAclr",
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWupSFCclr",
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWdnTOAclr",
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWdnSFCclr",
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM AMMA-MIP
+         CALL histdef(nid_day, "LWdnSFC",
+     .                "LW down at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "LWupSFC",
+     .                "LW down at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM     IF (iflag_con.GE.3) THEN 
+	  if (ok_ISCCP) then
+            CALL histdef(nid_day, "ptop",
+c    .                "Cld top pressure","mb",
+     .                "Cld top pressure (cf ISCCP simulator)","Pa",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+          ENDIF
+cIM     ENDIF !(iflag_con.GE.3) THEN 
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c   INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c=================================================================
+c
+         CALL histdef(nid_day, "tter", "Surface Temperature ter", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tlic", "Surface Temperature lic", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "toce", "Surface Temperature oce", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tsic", "Surface Temperature sic", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter", "Temp.tere 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mlic", "Temp.lic 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2moce", "Temp.oce 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2msic", "Temp.sic 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter_min", "Temp.terre 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter_max", "Temp.terre 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "u10mter", "Vent zonal ter 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10mlic", "Vent zonal lic 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10moce", "Vent zonal oce 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10msic", "Vent zonal sic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10mter", "Vent meridien ter 10m", 
+     .                "m/s", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10mlic", "Vent meridien lic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10moce", "Vent meridien oce 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10msic", "Vent meridien sic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_day, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_day, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress "//clnsurf(nsrf),"Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_day, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "rugs_"//clnsurf(nsrf), 
+     $         "Rugosite "//clnsurf(nsrf), "m",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+
+
+! FH Sorties specifiques pour Mellor et Yamada
+      if (iflag_pbl>1 .and. lev_histday.gt.10 ) then
+           call histdef(nid_day, "tke_"//clnsurf(nsrf), 
+     $         "Max Turb. Kinetic Energy "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_day, "tke_max_"//clnsurf(nsrf), 
+     $         "Max Turb. Kinetic Energy "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     $         "t_max(X)", zstophy,zout)
+      endif	
+
+C
+         END DO 
+C           
+c=================================================================
+c
+c   FIN INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+      ENDIF !lev_histday.GE.4
+c
+      IF(lev_histday.GE.5) THEN !lev_histday.GE.5
+c
+c rajout sorties F. Aires
+         CALL histdef(nid_day, "tops0", "CS Solar rad. at TOA", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "topl0", "CS IR rad. at TOA", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sols0", "CS Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "soll0", "CS Net IR rad. at surface", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rneb", "Cloud fraction", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "dqpbl", "PBL dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "dtwak", "Wake dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_day, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "wh", "Wake height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "ws", "Wake surface", "m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"meantaucld",
+     .                "ISCCP mean cloud optical thickness","1",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"cldtau","Cloud optical thickness","1",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"cldemi","Cloud optical emissivity","1",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c
+      CALL histdef(nid_day, "cin", "Conv Inhibition", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)      
+c
+         CALL histdef(nid_day, "wale", "Wake Available Energy", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "walp", 
+     .                "Available Lifting Energy due to wake", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "blale", "PBL Available Energy", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "blalp", 
+     .                "Available Lifting Energy due to PBL", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wdt1", 
+     .                "Temp diff wake layer 1", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wdq1", 
+     .                "Temp diff wake layer 1", "g/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cIM rajout AMMA-MIP
+c
+         CALL histdef(nid_day, "dtcon", "Convection dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "dqcon", "Convection dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rh2m", "Relative humidity at 2m", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "qsat2m", "Saturant humidity at 2m", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tpot", 
+     .                "Surface air potential temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tpote", 
+     .        "Surface air equivalent potential temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.5
+c=================================================================
+c
+         CALL histend(nid_day)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c=================================================================
+c$OMP END MASTER
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histday_seri.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histday_seri.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histday_seri.h	(revision 984)
@@ -0,0 +1,131 @@
+c
+c $Header$
+c
+cym Ne fonctionnera pas en mode parallele
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+c
+       zstophy = dtime
+       zout = ecrit_day
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+         imin_debut=1 
+         nbpti=1
+         jmin_debut=1 
+         nbptj=1
+c
+         CALL histbeg("histday_seri.nc", 
+     .                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 imin_debut,nbpti,jmin_debut,nbptj,
+     .                 itau_phy, zjulian, dtime,
+     .                 nhori, nid_day_seri)
+c
+         CALL histvert(nid_day_seri, "presnivs", 
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+         CALL histdef(nid_day_seri, "bilTOA", 
+     .                "Net radiation at model top", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "bils", 
+     .                "Net downward energy flux at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "ecin", 
+     .                "Total kinetic energy (per unit area)","J/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM 151004 BEG
+         IF(1.EQ.0) THEN
+c
+         CALL histdef(nid_day_seri, "momang", 
+     .               "Total relative angular momentum (per unit area)",
+     .               "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "frictor", 
+     .               "Friction torque (per unit area)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "mountor", 
+     .               "Mountain torque (per unit area)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF !(1.EQ.0) THEN
+c
+         CALL histdef(nid_day_seri, "momang", 
+     .               "Axial angular momentum (per unit area)",
+     .               "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "torsfc", 
+     .        "Total surface torque (including mountain torque)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM 151004 END        
+c
+         CALL histdef(nid_day_seri, "tamv", 
+     .                "Temperature (mass-weighted vert. ave)", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "psol", 
+     .                "Surface pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "evap", 
+     .                "Evaporation and sublimation (per unit area)", 
+     .                "kg/(m2*s)",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          call histdef(nid_day_seri, 
+c    .         "SnowFrac", 
+c    .         "Snow-covered area ", "%",  
+c    .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_day_seri, "snow_depth", 
+cIM 080904  .                "Snow Depth (water equivalent)", "m",
+cIM 191104  .                "Snow Depth (water equivalent)", "kg/m2",
+c    .                "Snow Mass", "kg/m2",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .               "ave(X)", zstophy,zout)
+c
+           call histdef(nid_day_seri, 
+     .         "tsol_"//clnsurf(is_oce), 
+     .         "SST over open (ice-free) ocean ", "K",  
+     .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+c=================================================================
+c
+         CALL histend(nid_day_seri)
+c
+c=================================================================
+      ENDIF ! fin de test sur type_run.EQ.AMIP
+      
+      ENDIF ! is_sequential
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histhf.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histhf.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histhf.h	(revision 984)
@@ -0,0 +1,402 @@
+!
+! $Header$
+!
+
+      IF (ok_hf) THEN
+c$OMP MASTER
+c
+       zstohf = ecrit_hf
+       zstophy = dtime
+       zstoday = ecrit_day
+       zout = ecrit_hf
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+cym         CALL histbeg("histhf", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_hf)
+
+         CALL histbeg_phy("histhf", itau_phy, zjulian, dtime, 
+     .                 nhori, nid_hf)
+
+         CALL histvert(nid_hf, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+         CALL histdef(nid_hf, "aireTER","Grid area CONT","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+         CALL histdef(nid_hf, "contfracATM","% sfce ter+lic ","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+         CALL histdef(nid_hf, "contfracOR","% sfce terre OR", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_hf, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "precip", "Precipitation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+cIM ENSEMBLES BEG
+         CALL histdef(nid_hf, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+          IF(bb2.EQ."500") THEN
+          CALL histdef(nid_hf, "phi"//bb2,
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+          ENDIF !bb2.EQ."500"
+         ENDDO !k=1, nlevSTD
+c
+      ENDIF !lev_histhf.GE.1
+c
+      IF(lev_histhf.GE.2) THEN
+c
+         CALL histdef(nid_hf, "cldt", "Total cloudiness", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "SWnetOR",
+     .                "Sfce net SW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "SWdownOR",
+     .                "Sfce incident SW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "LWdownOR",
+     .                "Sfce incident LW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+      ENDIF !lev_histhf.GE.2
+c
+cIM ENSEMBLES END
+c
+      IF(lev_histhf.GE.3) THEN
+c
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".or.bb2.EQ."700".OR.
+     $      bb2.EQ."500".or.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_hf, "t"//bb2,
+     .                 "Temperature "//bb2//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          IF(bb2.NE."500") THEN
+          CALL histdef(nid_hf, "phi"//bb2, 
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+          ENDIF
+c
+          CALL histdef(nid_hf, "q"//bb2,
+     .                 "Specific humidity "//bb2//"mb","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          CALL histdef(nid_hf, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          CALL histdef(nid_hf, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         ENDIF !IF(bb2.EQ."850".or.bb2.EQ."700".OR.
+c
+         ENDDO !nlevSTD
+c
+      ENDIF !lev_histhf.GE.3
+c
+      IF(lev_histhf.GE.4) THEN
+c
+cIM sorties hf 3D
+c
+#undef histhf3d
+#define histhf3d
+#ifdef histhf3d
+#include "ini_histhf3d.h"
+#endif
+      ENDIF !lev_histhf.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+        DO k=1, nlevSTD 
+c
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".or.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_hf, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb2.EQ."850".or.bb2.EQ."200"
+        ENDDO !k=1, nlevSTD
+c
+        CALL histdef(nid_hf, "topl", 
+     .       "Outgoing longwave radiation", "W/m2",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "precip","Total precipitation rate",
+     .       "kg/(s*m2)",iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .       "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "slp", 
+     .       "Mean sea-level pressure", "Pa",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "inst(X)", zstohf,zout)
+c
+cIM 280504 BEG
+      ENDIF !(lev_histhf.GE.1) THEN
+c
+      IF(lev_histhf.GE.2) THEN
+c
+        DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".OR.bb2.EQ."500") THEN
+c
+          CALL histdef(nid_hf, "t"//bb2,
+     .                 "Temperature "//bb2//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "q"//bb2,
+     .                 "Specific humidity "//bb2//"mb","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb2
+c
+         IF(bb2.EQ."500") THEN
+c
+          CALL histdef(nid_hf, "phi"//bb2,
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "w"//bb2,
+     .                 "Vertical motion "//bb2//"mb","Pa/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+         ENDIF !bb2.EQ."500"
+c
+         IF(bb3.EQ."50") THEN
+c
+          CALL histdef(nid_hf, "t"//bb3,
+     .                 "Temperature "//bb3//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "u"//bb3,
+     .                 "Zonal wind "//bb3//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "v"//bb3,
+     .                 "Meridional wind "//bb3//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb3
+c
+        ENDDO !k=1, nlevSTD
+c
+        CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "t2m", "Temperature 2m", "K",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "cldt", "Total cloudiness", "%",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "taux",
+     $         "Zonal wind stress","Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "tauy",
+     $         "Meridional wind stress ", "Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+cIM 090904  .                "ave(X)", zstohf,zout)
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+cIM 090904  .                "ave(X)", zstohf,zout)
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+c       CALL histdef(nid_hf, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf,"LWdnSFC","Down. IR rad. at surface",
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf,"LWupSFC","Upwd. IR rad. at surface",
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        DO k=1, nbteta
+         CALL histdef(nid_hf, "PV"//ctetaSTD(k),
+     $               "Vorticite potentielle "//ctetaSTD(k)//"K",
+     $               "1/(Pa*s)",iim,jj_nb,nhori, 1,1,1, -99,
+     $                 32, "inst(X)", zstohf,zout) 
+        ENDDO !k=1, nbteta
+c
+c planetary boundary layer height
+c
+c       ENDIF !1.EQ.0
+c
+      ENDIF !(lev_histhf.GE.2) THEN
+cIM 280504 END
+c
+      ENDIF !type_run
+c
+      CALL histend(nid_hf)
+c
+c$OMP END MASTER
+      ENDIF ! ok_hf
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histhf3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histhf3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histhf3d.h	(revision 984)
@@ -0,0 +1,51 @@
+c $Header$
+c
+c sorties hf 3d
+c
+        zstohf = ecrit_hf
+        zout = ecrit_hf
+c
+c       PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf
+c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+cym         CALL histbeg("histhf3d", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_hf3d)
+         CALL histbeg_phy("histhf3d", itau_phy, zjulian, dtime, 
+     .                 nhori, nid_hf3d)
+
+        CALL histvert(nid_hf3d, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+c Champs 3D:
+c
+        CALL histdef(nid_hf3d, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histend(nid_hf3d)
+c
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histins.h	(revision 984)
@@ -0,0 +1,292 @@
+!
+! $Header$
+!
+      IF (ok_instan) THEN
+c$OMP MASTER
+c
+          zsto = ecrit_ins
+          zout = ecrit_ins
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_ins)
+         CALL histbeg_phy("histins", itau_phy, zjulian, dtime,
+     .                 nhori, nid_ins)
+         write(*,*)'Inst ', itau_phy, zjulian
+         CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
+cIM    .                 klev, presnivs, nvert)
+     .                 klev, presnivs/100., nvert)
+c        call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
+c    .              klev, znivsig, nvert)
+c
+c
+         CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_ins, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+        CALL histdef(nid_ins, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "q2m", "Specific humidity 2m", "Kg/Kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+        CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c        CALL histdef(nid_ins, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "topl", "OLR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "evap", "Evaporation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_ins, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "tsol_"//clnsurf(nsrf), 
+     $         "Surface Temperature"//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+C
+           call histdef(nid_ins, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf),"Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional xind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "albe_"//clnsurf(nsrf), 
+     $         "Albedo "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "rugs_"//clnsurf(nsrf), 
+     $         "rugosite "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+CXXX
+         END DO 
+         CALL histdef(nid_ins, "rugs", "rugosity", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+c
+         CALL histdef(nid_ins, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+         CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c
+cIM cf. AM 081204 BEG
+c HBTM2
+         CALL histdef(nid_ins, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_pblt", "T at Boundary Layer Height", 
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_capCL", "Conv avlbl pot ener for 
+     .                ABL", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_cteiCL", "Instability criteria 
+     .                (ABL)", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs 3D:
+c
+         CALL histdef(nid_ins, "temp", "Temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "geop", "Geopotential height", "m",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+
+         CALL histend(nid_ins)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c$OMP END MASTER
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histmth.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histmth.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histmth.h	(revision 984)
@@ -0,0 +1,1953 @@
+c
+c $Header$
+c
+      IF (ok_mensuel) THEN
+c$OMP MASTER
+c
+       zstophy = dtime
+       zstomth = ecrit_mth                       !valeurs mensuelles "instantannees"
+       zstorad = dtime * FLOAT(radpas)    !variables stockees toutes les 2h
+       zstohf = ecrit_hf                         !variables stockees toutes les 6h
+       zout = ecrit_mth                          !frequence des sorties : 1 val. par mois
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_mth)
+
+           CALL histbeg_phy("histmth",itau_phy, zjulian, dtime, 
+     .                 nhori, nid_mth)
+     
+       write(*,*)'Mensuel ', itau_phy, zjulian
+         CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+!        CALL histdef(nid_mth, "dtthe", "Dry adjust. dT", "K/s",
+!    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+!    .                "ave(X)", zstophy,zout)
+!
+!        CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
+!    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+!    .                "ave(X)", zstophy,zout)
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+         CALL histdef(nid_mth, "phis", 
+     .                "Surface geop. height", "m2/s2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_ter), 
+     .         "% "//clnsurf(is_ter), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_ter), 
+     .         "Fraction "//clnsurf(is_ter), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c ENSEMBLES BEG
+c        CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                t2mincels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                t2maxcels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c ENSEMBLES END
+         CALL histdef(nid_mth, "q2m", "Specific humidity 2m", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "qsurf", "Surface Air humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      if (.not. ok_veget) then
+         CALL histdef(nid_mth, "qsol", "Soil watter content", "mm",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+c        CALL histdef(nid_mth, "ndayrain", 
+c    .                "Number of day with rain (liq+sol)", "-",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "inst(X)", zstomth,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "snow", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "evap", "Evaporation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops0", "CS Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOAclr", 
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOAclr", 
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200", "SWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200clr", 
+     .                "SWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200", "SWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200clr", 
+     .                "SWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200", "LWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200clr", 
+     .                "LWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200", "LWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200clr", 
+     .                "LWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFCclr", 
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFCclr", 
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFCclr",
+     .                "CS Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFCclr",
+     .                "Down. CS IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c Effets des aerosols
+c
+      IF (ok_ade.OR.ok_aie) THEN
+         CALL histdef(nid_mth, "topsad", "ADE at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "solsad", "ADE at sfc", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topsai", "AIE at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "solsai", "AIE at sfc", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+c          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting",
+     .                "W/m2",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqcalving","Ice Calving",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqfonte","Land ice melt",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+
+         DO nsrf = 1, nbsrf
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+         ENDDO
+c
+         DO nsrf = 1, nbsrf
+C
+          IF(nsrf.GE.2) THEN
+           call histdef(nid_mth, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+          ENDIF !nsrf.GT.2
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "flw_"//clnsurf(nsrf),
+     $         "LW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fsw_"//clnsurf(nsrf),
+     $         "SW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbils_"//clnsurf(nsrf),
+     $         "Bilan sol "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbilo_"//clnsurf(nsrf),
+     $         "Bilan eau "//clnsurf(nsrf), "kg/(m2*s)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+cIM 250105 BEG
+          IF(1.EQ.0) THEN
+C
+           call histdef(nid_mth, "evapour_"//clnsurf(nsrf),
+     $         "Evap*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "prepour_"//clnsurf(nsrf),
+     $         "Precip*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+          ENDIF !(1.EQ.0) THEN
+cIM 250105 END
+C
+         END DO
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cKE43
+      IF(iflag_con.GE.3) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !iflag_con .GE. 3
+c34EK
+cIM cf. AM 081204 BEG
+c34EK
+c HBTM2
+         CALL histdef(nid_mth, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_pblt", "t at Boundary Layer Height",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_capCL", "Conv avlbl pot ener 
+     .                for ABL", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_cteiCL", "Instability criteria 
+     .                (ABL)", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs interpolles sur des niveaux de pression
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_mth, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "w"//bb2,
+     .                 "Vertical wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "phi"//bb2,
+     .                 "Geopotential "//bb2//"mb","m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+        ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+       ENDDO
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+       CALL histdef(nid_mth, "fluxo",
+     .              "Flux turbulents ocean-atmosphere", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "fluxg",
+     .              "Flux turbulents ocean-glace de mer","W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "t_oce_sic",
+     .              "Temp. mixte oce-sic","K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       IF (OCEAN.EQ.'force ') THEN
+c
+        CALL histdef(nid_mth, "lmt_bils",
+     .       "Bilan au sol atmosphere forcee", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+        CALL histdef(nid_mth, "slab_bils",
+     .       "Bilan au sol Slab", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "tslab", "Slab SST ", "K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "seaice", "Slab seaice", "kg/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "siceh", "Slab seaice height", "m",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ENDIF
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+c
+c
+         CALL histdef(nid_mth,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "ppmv",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqphy", "Physics dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+        DO nsrf=1, nbsrf
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+	 ENDDO !nsrf=1, nbsrf
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.3
+c
+      IF(lev_histmth.GE.4) THEN
+c
+!FH Sorties pour la couche limite
+      if (iflag_pbl>1) then
+         CALL histdef(nid_mth, "tke","TKE","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tke_max","TKE max","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "kz","Kz melange","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "kz_max","Kz melange max","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+
+
+         CALL histdef(nid_mth, "clwcon", 
+     .                "Convective Cloud Liquid water content"
+     .                , "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+
+
+c
+c        CALL histdef(nid_mth, "ducon", "Convection du", "m/s2",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqcon", "Convection dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlschr",
+     $     "Large-scale condensational heating rate", "K/s",iim,jj_nb
+     $     ,nhori, klev,1,klev,nvert, 32,"ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqvdf","Boundary-layer dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqeva","Reevaporation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "dtthe", "Dry adjust. dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth,"dqthe","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth,"dqajs","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+         CALL histdef(nid_mth, "tau", "cloud opt thickness", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM1", "CCM1", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM2", "CCM2", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "cldemi", "emissivite IR", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_NAT", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AD", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AI", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AD", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_NAT", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+#endif
+#ifndef INCA
+         if (nqmax.GE.3) THEN
+           DO iq=3,nqmax
+             iiq=niadv(iq)
+             CALL histdef(nid_mth, tnom(iq), ttext(iiq), "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+             ENDDO
+           ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+         CALL histdef(nid_mth, "phis", "Surface geop. height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_ter), 
+     .         "% "//clnsurf(is_ter), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_ter), 
+     .         "Fraction "//clnsurf(is_ter), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_lic), 
+     .         "% "//clnsurf(is_lic), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_lic), 
+     .         "Fraction "//clnsurf(is_lic), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_sic),
+     .         "% "//clnsurf(is_sic), "%",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_sic),
+     .         "Fraction "//clnsurf(is_sic), "1",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bilTOA",
+     .                "Net radiation at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c
+c        CALL histdef(nid_mth, "tops01",
+c    .                "TOA reflected clear-sky shortwave 
+c    .                radiation (method 1)", "W/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtdia","dtdia","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtsw","dtsw","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtlw","dtlw","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dqthe","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtajs","dtajs","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtlsc","dtlsc","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dqdia","dqdia","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "duoli",
+     .         "duoli","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvoli",
+     .         "dvoli","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "ducon",
+     .         "ducon","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvcon",
+     .         "dvcon","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dutot",
+     .         "dutot","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvtot",
+     .         "dvtot","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c         CALL histdef(nid_mth, "cldtrue",
+c    .         "TRUE Cloud fraction ","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "inst(X)", zout,zout)
+c
+c         CALL histdef(nid_mth, "cldTOA",
+c    .         "Cloud amount (satellite view)","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+c         CALL histdef(nid_mth, "cldSFC",
+c    .         "Cloud amount (surface view)","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "GWDtaux",
+     .         "GWD induced Ewd wind stress","Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "GWDtauy",
+     .         "GWD induced Nwd wind stress","Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+c        CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                t2mincels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                t2maxcels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "q2m","Specific humidity 2m","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "qsurf","Surface Air humidity","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      if (.not. ok_veget) then
+         CALL histdef(nid_mth, "qsol", "Soil watter content", "mm",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "ndayrain", 
+     .                "Number of day with rain (liq+sol)", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstomth,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "snowf", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "evap", 
+     .                "Evaporation plus sublimation rate", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops0", "CS Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOAclr", 
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOAclr", 
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200", "SWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200clr", 
+     .                "SWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200", "SWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200clr", 
+     .                "SWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200", "LWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200clr", 
+     .                "LWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200", "LWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200clr", 
+     .                "LWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFCclr", 
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFCclr", 
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFCclr",
+     .                "CS Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFCclr",
+     .                "Down. CS IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c Effets des aerosols
+c
+         IF (ok_ade.OR.ok_aie) THEN
+             CALL histdef(nid_mth, "topsad", "ADE at TOA", "W/m2",
+     .                    iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                    "ave(X)", zstophy,zout)
+c
+             CALL histdef(nid_mth, "solsad", "ADE at sfc", "W/m2",
+     .                    iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                    "ave(X)", zstophy,zout)
+c
+             CALL histdef(nid_mth, "topsai", "AIE at TOA", "W/m2",
+     .                    iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                    "ave(X)", zstophy,zout)
+c
+             CALL histdef(nid_mth, "solsai", "AIE at sfc", "W/m2",
+     .                    iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                    "ave(X)", zstophy,zout)
+         ENDIF
+c
+c          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting",
+     .                "W/m2",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqcalving","Ice Calving",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         DO nsrf = 1, nbsrf
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+         ENDDO
+c
+           call histdef(nid_mth, "pourc_"//clnsurf(is_oce), 
+     $         "% "//clnsurf(is_oce), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fract_"//clnsurf(is_oce), 
+     $         "Fraction "//clnsurf(is_oce), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "flw_"//clnsurf(nsrf),
+     $         "LW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fsw_"//clnsurf(nsrf),
+     $         "SW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbils_"//clnsurf(nsrf),
+     $         "Bilan sol "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbilo_"//clnsurf(nsrf),
+     $         "Bilan eau "//clnsurf(nsrf), "kg/(m2*s)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+cIM 250105 BEG
+          IF(1.EQ.0) THEN
+C
+           call histdef(nid_mth, "evapour_"//clnsurf(nsrf),
+     $         "Evap*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "prepour_"//clnsurf(nsrf),
+     $         "Precip*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+          ENDIF !(1.EQ.0) THEN
+cIM 250105 END
+C
+         END DO
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cKE43
+      IF(iflag_con.GE.3) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !iflag_con .GE. 3
+c34EK
+cIM cf. AM 081204 BEG
+c34EK
+c HBTM2
+         CALL histdef(nid_mth, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_pblt", "T at Boundary Layer Height",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth,"s_capCL","Conv avlbl pot ener for ABL",
+     .                "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth,"s_cteiCL","Instability criteria (ABL)",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs interpolles sur des niveaux de pression
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+       IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_mth, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "w"//bb2,
+     .                 "Vertical wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "phi"//bb2,
+     .                 "Geopotential "//bb2//"mb","m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."850".OR.bb2.EQ."700"
+c
+       ENDDO !nlevSTD
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+       CALL histdef(nid_mth, "fluxo",
+     .              "Flux turbulents ocean-atmosphere", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "fluxg",
+     .              "Flux turbulents ocean-glace de mer","W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "t_oce_sic",
+     .              "Temp. mixte oce-sic","K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       IF (OCEAN.EQ.'force ') THEN
+c
+        CALL histdef(nid_mth, "lmt_bils",
+     .       "Bilan au sol atmosphere forcee", "W/m2",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "ave(X)", zstophy,zout)
+c
+       ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+        CALL histdef(nid_mth, "slab_bils",
+     .              "Bilan au sol Slab", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "tslab", "Slab SST ", "K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "seaice", "Slab seaice", "kg/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "siceh", "Slab seaice height", "m",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ENDIF !OCEAN.EQ.slab/force
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+c
+c
+         CALL histdef(nid_mth,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "rneb", "Cloud fraction", "%",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "ppmv",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqphy","Physics dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+        DO nsrf=1, nbsrf
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Rugosite "//clnsurf(nsrf), "m",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+	 ENDDO !nsrf=1, nbsrf
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.3
+c
+      IF(lev_histmth.GE.4) THEN
+c
+!FH Sorties pour la couche limite
+      if (iflag_pbl>1) then
+         CALL histdef(nid_mth, "tke","TKE","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tke_max","TKE max","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "kz","Kz melange","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "kz_max","Kz melange max","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+
+
+
+
+         CALL histdef(nid_mth, "clwcon", 
+     .                "Convective Cloud Liquid water content"
+     .                , "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqdyn","Dynamics dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqcon","Convection dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlschr",
+     $       "Large-scale condensational heating rate", "K/s",
+     $       iim,jj_nb
+     $       ,nhori, klev,1,klev,nvert, 32,"ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqlsc","Condensation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqvdf","Boundary-layer dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dqeva","Reevaporation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "dqajs","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+         CALL histdef(nid_mth, "tau", "cloud opt thickness", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM1", "CCM1", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM2", "CCM2", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "cldemi", "emissivite IR", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_NAT", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AD", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AI", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_ZERO", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AER", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AD", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_NAT", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+#endif
+#ifndef INCA
+         if (nqmax.GE.3) THEN
+         DO iq=3,nqmax
+         iiq=niadv(iq)
+         CALL histdef(nid_mth, tnom(iq), ttext(iiq), "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDDO
+         ENDIF
+#endif
+
+      ENDIF !lev_histmth.GE.4
+c
+      ENDIF !type_run.EQ."CLIM".OR.type_run.EQ."ENSP")
+c
+         CALL histend(nid_mth)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c$OMP END MASTER
+      ENDIF ! fin de test sur ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histmthNMC.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histmthNMC.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histmthNMC.h	(revision 984)
@@ -0,0 +1,185 @@
+!
+! $Header$
+!
+      IF (ok_mensuel) THEN
+c
+c$OMP MASTER
+
+       zstophy = dtime
+       zstohf = ecrit_hf
+       zstomth = ecrit_mth
+       zout = ecrit_mth
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_nmc)
+
+         CALL histbeg_phy("histNMC",itau_phy, zjulian, dtime, 
+     .                 nhori, nid_nmc)
+c
+         CALL histvert(nid_nmc, "presnivs", "Vertical levels", "mb",
+     .                 nlevSTD, rlevSTD/100., nvert)
+ccc
+ccc Champs 3D interpolles sur des niveaux de pression du NMC
+ccc
+      IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+          CALL histdef(nid_nmc, "temp",
+     .                 "Temperature","K",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "phi",
+     .                "Geopotential", "m",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "q",
+     .                 "Specific humidity","kg/kg",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "rh",
+     .                 "Relative humidity", "%",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "u",
+     .                 "Zonal wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "v",
+     .                 "Meridional wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+c             sur les niveaux du NMC et on somme & moyenne
+c             toutes les 6 heures par des routines undefSTD et
+c             moy_undefSTD pour eliminer les valeurs "undef"
+c             de la moyenne mensuelle
+c ======> le "inst(X)" ci-dessous est par consequence factice !
+c
+          CALL histdef(nid_nmc, "temp",
+     .                 "Temperature","K",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "phi",
+     .                "Geopotential ", "m",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "q",
+     .                 "Specific humidity","kg/kg",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "rh",
+     .                 "Relative humidity", "%",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "u",
+     .                 "Zonal wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "v",
+     .                 "Meridional wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "w",
+     .                 "Vertical motion","Pa/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+c             sur les niveaux du NMC et on somme & moyenne
+c             toutes les 6 heures par des routines undefSTD et
+c             moy_undefSTD pour eliminer les valeurs "undef"
+c             de la moyenne mensuelle
+c ======> le "inst(X)" ci-dessus est par consequence factice !
+c
+c
+          CALL histdef(nid_nmc, "psbg",
+     .         "Pressure sfce below ground","%",
+     .         iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "uv",
+     .         "uv ",
+     .         "m2/s2",iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vq",
+     .         "vq ",
+     .         "m/s * (kg/kg)",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vT",
+     .         "vT ", 
+     .         "mK/s",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "wq",
+     .         "wq ", 
+     .         "(Pa/s)*(kg/kg)",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vphi",
+     .         "vphi ", 
+     .         "m2/s",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "wT",
+     .         "wT ", 
+     .         "K*Pa/s",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "uxu",
+     .         "u2 ", 
+     .         "m2/s2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vxv",
+     .         "v2 ", 
+     .         "m2/s2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "TxT",
+     .         "T2 ", 
+     .         "K2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+      ENDIF !(type_run.EQ."AMIP")
+
+         CALL histend(nid_nmc)
+c
+c$OMP END MASTER
+
+      ENDIF ! fin de test sur ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_histrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_histrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_histrac.h	(revision 984)
@@ -0,0 +1,132 @@
+!
+! $Header$
+!
+      IF (config_inca == 'none') THEN
+c$OMP MASTER 
+         CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = xlon(i+1)
+cym            zx_lon(i,jjm+1) = xlon(i+1)
+cym         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlat,zx_lat)
+cym         CALL histbeg("histrac", iim,zx_lon(:,1), jjm+1,zx_lat(1,:),
+cym     .                 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys,
+cym     .                 nhori, nid_tra)
+         CALL histbeg_phy("histrac", itau_phy, zjulian, pdtphys,
+     .                 nhori, nid_tra)
+         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+
+
+
+         zsto = pdtphys
+         zout = ecrit_tra
+c
+         CALL histdef(nid_tra, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+c
+         CALL histdef(nid_tra, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+         DO it=1,nqmax
+C champ 2D
+         iq=it+2
+         iiq=niadv(iq)
+         CALL histdef(nid_tra, tnom(iq), ttext(iiq), "U/kga",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         if (lessivage) THEN
+         CALL histdef(nid_tra, "fl"//tnom(iq),"Flux "//ttext(iiq),
+     .              "U/m2/s",iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+         endif
+
+c---Ajout Olivia
+         CALL histdef(nid_tra, "d_tr_th_"//tnom(iq),
+     .	              "tendance thermique"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         if(iflag_con.GE.2) then
+         CALL histdef(nid_tra, "d_tr_cv_"//tnom(iq),
+     .	              "tendance convection"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+	     endif !(iflag_con.GE.2) then
+         CALL histdef(nid_tra, "d_tr_cl_"//tnom(iq),
+     .	              "tendance couche limite"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c---fin Olivia	 
+
+         ENDDO
+
+         CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+
+         CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf1", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf2", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf3", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf4", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol1", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol2", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol3", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst",  zout,zout)
+         CALL histdef(nid_tra, "ftsol4", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "pplay", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zout,zout)
+         CALL histdef(nid_tra, "t", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zout,zout)
+         CALL histdef(nid_tra, "mfu", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "mfd", "flux u decen","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_u", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_d", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_d", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_u", "flux u decen","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "coefh", "turbulent coef","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+c
+         CALL histend(nid_tra)
+         ndex2d = 0
+         ndex3d = 0
+         ndex = 0
+c$OMP END MASTER
+      END IF
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_paramLMDZ_phy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_paramLMDZ_phy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_paramLMDZ_phy.h	(revision 984)
@@ -0,0 +1,367 @@
+cym    Non implemente en mode parallele
+
+       IF (is_sequential) THEN  
+c
+       zstophy = dtime
+       zout = ecrit_day
+c
+       idayref = day_ref
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+       if (iim.gt.1) then
+       DO i = 1, iim
+         zx_lon(i,1) = rlon(i+1)
+         zx_lon(i,jjmp1) = rlon(i+1)
+       ENDDO
+       endif
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+       CALL histbeg("paramLMDZ_phy.nc", 
+     .                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,1,1,1,
+     .                 itau_phy, zjulian, dtime,
+     .                 nhori, nid_ctesGCM)
+c
+c Variables type caractere : plusieurs valeurs possibles
+c
+       CALL histdef(nid_ctesGCM, "ocean", 
+     .        "Type ocean utilise: 1=force, 2=slab, 3=couple",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_slab_sicOBS",
+     ."ok_slab_sicOBS= 1: glace de mer observee, =0: gl.mer calculee 
+     . par le slab", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "type_run",
+     .        "Type run: 1= CLIM ou ENSP, 2= AMIP ou CFMI",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c Variables logiques (1=true, 0=false)
+c
+       CALL histdef(nid_ctesGCM, "ok_veget", 
+     .        "Type de modele de vegetation: 1=ORCHIDEE, 0=bucket",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_journe", 
+     .        "Creation du fichier histday: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_mensuel", 
+     .        "Creation du fichier histmth: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_instan", 
+     .        "Creation du fichier histins: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_ade", 
+     .        "Aerosol direct effect: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_aie", 
+     .        "Aerosol indirect effect: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "bl95_b0", 
+     .        "Parameter in CDNC-maer link (Boucher&Lohmann 1995)",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "bl95_b1", 
+     .        "Parameter in CDNC-maer link (Boucher&Lohmann 1995)",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ip_ebil_phy", 
+     .                "Niveau sortie diags bilan energie cote physique",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_ecc", 
+     .                "Excentricite","-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_peri", 
+     .                "Equinoxe","-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_incl", 
+     .                "Inclinaison","deg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "solaire", 
+     .                "Constante solaire","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "co2_ppm", 
+     .                "Concentration du CO2", "ppm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CH4_ppb", 
+     .                "Concentration du CH4", "ppb",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "N2O_ppb",
+     .                "Concentration du N2O", "ppb",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CFC11_ppt",
+     .                "Concentration du CFC11", "ppt",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CFC12_ppt",
+     .                "Concentration du CFC12", "ppt",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "epmax",
+     .                "Efficacite precip", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_adj_ema",
+     .                "ok_adj_ema: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_clw",
+     .                "iflag_clw", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_lc_lsc",
+     .                "cld_lc_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_lc_con",
+     .                "cld_lc_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_tau_lsc",
+     .                "cld_tau_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_tau_con",
+     .                "cld_tau_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ffallv_lsc",
+     .                "ffallv_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ffallv_con",
+     .                "ffallv_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "coef_eva",
+     .                "coef_eva", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "reevap_ice",
+     .                "reevap_ice: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_cldcon",
+     .                "iflag_cldcon", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_pdf",
+     .                "iflag_pdf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "fact_cldcon",
+     .                "fact_cldcon", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "facttemps",
+     .                "facttemps", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_newmicro",
+     .                "Nouvelle micro-physique: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ratqsbas",
+     .                "ratqsbas", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ratqshaut",
+     .                "ratqshaut", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_froid",
+     .                "rad_froid", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_chau1",
+     .                "rad_chau1", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_chau2",
+     .                "rad_chau2", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "top_height",
+     .                "top_height", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "overlap",
+     .                "overlap", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cdmmax",
+     .                "cdmmax", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cdhmax",
+     .                "cdhmax", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ksta",
+     .                "ksta", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ksta_ter",
+     .                "ksta_ter", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_kzmin",
+     .                "ok_kzmin: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_pbl",
+     .                "iflag_pbl", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histhf",
+     .                "lev_histhf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histday",
+     .                "lev_histday", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histmth",
+     .                "lev_histmth", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_isccp",
+     .                "Creation fichier histISCCP: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lonmin_ins",
+     .                "lonmin_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lonmax_ins",
+     .                "lonmax_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "latmin_ins",
+     .                "latmin_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "latmax_ins",
+     .                "latmax_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_ins",
+     .                "ecrit_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_hf",
+     .                "ecrit_hf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_day",
+     .                "ecrit_day", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_mth",
+     .                "ecrit_mth", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_tra",
+     .                "ecrit_tra", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_reg",
+     .                "ecrit_reg", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "freq_ISCCP",
+     .                "freq_ISCCP", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_ISCCP",
+     .                "ecrit_ISCCP", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c=================================================================
+c
+       CALL histend(nid_ctesGCM)
+       
+       ENDIF ! is_sequential
+c
+c=================================================================
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_undefSTD.F	(revision 984)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+
+      SUBROUTINE ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $           tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Initialisation - a des frequences differentes : 
+c
+c 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
+c    calculees a partir des valeurs "instantannees" de la physique
+c
+c 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
+c    toutes les 6 heures
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c              ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c              ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+c
+cym #include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym #include "dimphy.h"
+c variables Input/Output
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime
+      REAL ecrit_day,ecrit_mth
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+c
+c variables Output
+      REAL tnondef(klon,klevSTD,nout)
+      REAL tsumSTD(klon,klevSTD,nout)
+c
+c initialisation variables journalieres en debut de journee
+c
+      IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.1.) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,1)=0.
+         tsumSTD(i,k,1)=0.
+        ENDDO !i
+       ENDDO !k
+      ENDIF
+c
+c initialisation variables mensuelles (calculees a chaque pas de temps) 
+c en debut de mois : nout=2
+c
+      IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.1.) THEN
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,2)=0.
+         tsumSTD(i,k,2)=0.
+        ENDDO !i
+       ENDDO !k
+c
+c initialisation variables mensuelles - runs type Amip - (calculees toutes les 6h)
+c en debut de mois : nout = 3
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,3)=0.
+         tsumSTD(i,k,3)=0.
+        ENDDO !i
+       ENDDO !k
+c
+      ENDIF
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ini_wake.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ini_wake.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ini_wake.F	(revision 984)
@@ -0,0 +1,73 @@
+      SUBROUTINE INI_WAKE(wape,fip,it_wape_prescr,
+     :     wape_prescr, fip_prescr, alp_bl_prescr, ale_bl_prescr)
+***************************************************************
+*                                                             *
+*        INI_WAKE : variables d'initialisation de la poche    *
+*                   froide, necessaires au declenchement      *
+*                   de la convection.                         *
+*                                                             *
+*                                                             *
+***************************************************************
+c Arguments
+c =========
+c Input
+c -----
+c   wape           : valeur de l'energie potentielle de la poche (WAPE)
+c                    dans l'etat initial
+c   fip            : valeur de la puissance incidente sur le front (FIP)
+c                    dans l'etat initial
+c Output
+c ------
+c   it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE
+c            doit etre imposee.
+c   wape_prescr    : valeur prescrite de la WAPE.
+c   fip_prescr     : valeur prescrite de la FIP.
+c
+c Variables internes
+c ==================
+c   it = nbre de pas de temps lu
+c   w  = WAPE lue
+c   f  = FIP lue
+c
+cdeclarations
+      real ale_bl_prescr
+      real alp_bl_prescr
+      real it
+cCR: on rajoute ale et alp de la PBL precrits
+c     open (99,file='wake.data',form='formatted')
+c     read (99,*) it
+c     read (99,*) w
+c     read (99,*) f
+c     read (99,*) u
+c     read (99,*) p
+c     close (99)
+
+! FH A mettre si besoin dans physiq.def
+! FH : voir avec JYG
+      it=0.
+      w=4.
+      f=0.1
+      u=0.1
+      p=4.
+c
+      print *,' it,w ',it,w
+      it_wape_prescr = it
+      if (w .lt. 0) then
+         wape_prescr = wape
+         fip_prescr = fip
+      else
+         wape_prescr = w
+         fip_prescr = f
+      endif
+c
+      print *,' u,p ',u,p
+      alp_bl_prescr=u
+      ale_bl_prescr=p
+      print *,'Initialisation de la poche : WAPE, FIP imposees ='
+     $               ,wape_prescr, fip_prescr
+      print *, '                   pendant ',it_wape_prescr,' steps'
+c
+      print *,'Initialisation de la BL: ALP, ALE imposees ='
+     $               ,alp_bl_prescr, ale_bl_prescr
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/inifis.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/inifis.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/inifis.F	(revision 984)
@@ -0,0 +1,73 @@
+!
+! $Header$
+!
+      SUBROUTINE inifis(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,
+     $           prad,pg,pr,pcpp)
+      use dimphy
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon)
+      INTEGER pdayref
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon
+         STOP
+      ENDIF
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/iniphysiq.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/iniphysiq.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/iniphysiq.F	(revision 984)
@@ -0,0 +1,99 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE iniphysiq(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,pcu,pcv,
+     $           prad,pg,pr,pcpp)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE comgeomphy
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "comgeomphy.h"
+#include "YOMCST.h"
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon_glo)
+      REAL pcu(klon_glo),pcv(klon_glo)
+      INTEGER pdayref
+      INTEGER :: ibegin,iend,offset
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon_glo) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon_glo
+         STOP
+      ENDIF
+c$OMP PARALLEL PRIVATE(ibegin,iend) 
+c$OMP+         SHARED(parea,pcu,pcv,plon,plat)
+      
+      offset=klon_mpi_begin-1
+      airephy(1:klon_omp)=parea(offset+klon_omp_begin:
+     &                          offset+klon_omp_end)
+      cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end)
+      cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end)
+      rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end)
+      rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end)
+
+      call suphel
+
+c$OMP END PARALLEL
+
+      print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ'
+      print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...'
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/init_phys_lmdz.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/init_phys_lmdz.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/init_phys_lmdz.F90	(revision 984)
@@ -0,0 +1,24 @@
+!
+!$Header$
+!
+SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nbtr,nb_proc,distrib)
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE dimphy, ONLY : Init_dimphy
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: llm
+    INTEGER,INTENT(in) :: nbtr
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+
+    CALL Init_grid_phy_lmdz(iim,jjp1,llm)
+    CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL Init_dimphy(klon_omp,nbp_lev,nbtr)
+!$OMP END PARALLEL
+ 
+END SUBROUTINE Init_Phys_lmdz  
Index: LMDZ4/tags/LF_20080728/libf/phylmd/initphysto.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/initphysto.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/initphysto.F	(revision 984)
@@ -0,0 +1,304 @@
+!
+! $Header$
+!
+C
+C
+      subroutine initphysto
+     .  (infile,
+     .  rlon, rlat, tstep,t_ops,t_wrt,nq,fileid)
+       
+       USE dimphy
+       USE mod_phys_lmdz_para
+       USE IOIPSL
+       USE iophy
+      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   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 "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+cym#include "dimphy.h"
+
+C   Arguments
+      character*(*) infile
+      integer*4 nhoriid, i
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq,l
+      real nivsigs(llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, idayref
+      logical ok_sync
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+C
+      REAL rlon(klon), rlat(klon)
+
+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 = 0
+	
+cym	CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjm+1) = rlon(i+1)
+cym         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+
+
+      call histbeg_phy(infile,tau0, zjulian, tstep,
+     .                 nhoriid, fileid)
+
+c$OMP MASTER	
+C  Appel a histvert pour la grille verticale
+C
+	DO l=1,llm
+            nivsigs(l)=float(l)
+         ENDDO
+
+	write(*,*) 'avant histvert ds initphysto'
+
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+	write(*,*) 'apres histvert ds initphysto'
+
+       CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+c
+	write(*,*) 'apres phis ds initphysto'
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         write(*,*) 'apres aire ds initphysto'
+
+cym     Attention dtime et istphy ne sont pas �rit ---> a �iminer ?
+         CALL histdef(fileid, "dtime", "tps phys ", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	 CALL histdef(fileid, "istphy", "tps stock", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+C T 
+C
+      call histdef(fileid, 't', 'Temperature', 'K',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres t ds initphysto'
+C mfu 
+C
+      call histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres mfu ds initphysto'
+C
+C mfd 
+C
+      call histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_u 
+C
+      call histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+               write(*,*) 'apres en_u ds initphysto'
+C
+C de_u 
+C
+      call histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_d 
+C
+      call histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C de_d 
+C
+      call histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c coefh frac_impa,frac_nucl
+	
+	call histdef(fileid, "coefh", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c abderrahmane le 16 09 02
+        call histdef(fileid, "fm_th", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+        call histdef(fileid, "en_th", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+c fin aj
+	
+	write(*,*) 'apres coefh ds initphysto'	
+
+	call histdef(fileid, 'frac_impa', ' ', ' ',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+	
+	call histdef(fileid, 'frac_nucl', ' ', ' ',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c
+c pyu1
+c
+      CALL histdef(fileid, "pyu1", " ", " ",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+
+c
+c pyv1
+c
+	CALL histdef(fileid, "pyv1", " ", " ",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'apres pyv1 ds initphysto'
+c
+c ftsol1
+c
+	call histdef(fileid, "ftsol1", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol2
+c
+        call histdef(fileid, "ftsol2", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol3
+c
+        call histdef(fileid, "ftsol3", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol4
+c
+        call histdef(fileid, "ftsol4", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c rain
+c
+        call histdef(fileid, "rain", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf1
+c
+	call histdef(fileid, "psrf1", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c psrf2
+c
+        call histdef(fileid, "psrf2", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf3
+c
+        call histdef(fileid, "psrf3", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf4
+c
+        call histdef(fileid, "psrf4", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'avant histend ds initphysto'	
+
+      call histend(fileid)
+c     if (ok_sync) call histsync(fileid)
+      if (ok_sync) call histsync
+c$OMP END MASTER
+	
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/initrrnpb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/initrrnpb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/initrrnpb.F	(revision 984)
@@ -0,0 +1,124 @@
+!
+! $Header$
+!
+      SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: initialisation des constantes des traceurs
+CAA Revison pour le controle avec la temperature du sol
+cAA
+CAA   it = 1 radon ss controle de ts
+cAA   it = 2 plomb ss controle de ts  
+c======================================================================
+c Arguments:
+c nbtr------input-I- nombre de vrais traceurs (sans l'eau)
+c ftsol-------input-R- Temperature du sol (Kelvin)
+c pctsrf-----input-R-  Nature de sol (pourcentage de sol)
+c masktr---output-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----output-R- Flux surfacique de production dans le sol
+c hsoltr---output-R- Epaisseur du reservoir de sol
+c tautr----output-R- Constante de decroissance du traceur
+c vdeptr---output-R- Vitesse de depot sec dans la couche Brownienne
+c scavtr---output-R- Coefficient de lessivage
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+c======================================================================
+C
+      INTEGER i, it
+      REAL pctsrf(klon,nbsrf) !Pourcentage de sol (f(nature du sol))
+      REAL ftsol(klon,nbsrf)  ! Temperature du sol pour le controle Rn
+c                             ! le cas echeant
+      REAL masktr(klon,nbtr)  ! Masque de l'echange avec la surface
+c                                 (possible => 1 )
+      REAL fshtr(klon,nbtr)  ! Flux surfacique dans le reservoir de sol
+      REAL hsoltr(nbtr)      ! Epaisseur equivalente du reservoir de sol
+      REAL tautr(nbtr)       ! Constante de decroissance radioactive
+      REAL vdeptr(nbtr)      ! Vitesse de depot sec dans la couche Brownienne
+      REAL scavtr(nbtr)      ! Coefficient de lessivage
+      REAL s
+C
+      WRITE(*,'(''PASSAGE initrrnpb ...'',$)')
+      print*,'nbtr= ',nbtr
+      print*,'nbsrf= ',nbsrf
+      print*,'klon= ',klon
+C
+C Puis les initialisation specifiques a chaque traceur (pour le moment, Rn222)
+C
+C
+C Radon it = 1
+c
+      IF ( nbtr .LE. 0 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 1
+      s = 1.E4  !  Source: atome par m2
+      hsoltr(it) = 0.1      ! Hauteur equivalente du reservoir : 
+c                              1 m * porosite 0.1
+      tautr(it) = 4.765E5  ! Decroissance du radon, secondes
+cAA
+c      tautr(it) = 4.765E55  ! Decroissance du radon,infinie
+cAA
+      vdeptr(it) = 0. ! Pas de depot sec pour le radon
+      scavtr(it) = 0. ! Pas de lessivage pour le radon
+
+      print*, '-------------- SOURCE DU RADON ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+
+      DO i = 1,klon
+        masktr(i,it) = 0.
+        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
+        fshtr(i,it) = s * masktr(i,it)
+
+cAA
+cAA quelques tests
+cAA POur l'instant le pctsrf(i,3) = 1.0 
+cAA lorsqu'il ya de la terre mias ne prend aucune autre valeur
+cAA il n'est donc pas necessaire de multiplier fshtr par pctsrf
+cAA 
+c       print*, '------------------------------------------ '
+c        print*, 'masktr(',i,it,')= ',masktr(i,it)
+c        print*, 'fshtr(',i,it,')= ',fshtr(i,it)
+c        print*, 'pctsrf(',i,',1)= ',pctsrf(i,1)
+c        print*, 'pctsrf(',i,',2)= ',pctsrf(i,2)
+c        print*, 'pctsrf(',i,',3)= ',pctsrf(i,3)
+c        print*, 'pctsrf(',i,',4)= ',pctsrf(i,4)
+c        print*, 's = ',s
+c        print*, '------------------------------------------ '
+
+      END DO
+C
+C 210Pb it = 2
+C
+      IF ( nbtr .LE. 1 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 2
+      s = 0. !  Pas de source !!!
+      hsoltr(it) = 10.     ! Hauteur equivalente du reservoir 
+c                              a partir duquel le
+c                              depot Brownien a lieu
+      tautr(it) = 1.028E9 ! Decroissance du Pb210, secondes
+      vdeptr(it) = 1.E-3 ! 1 mm/s pour le 210Pb
+      scavtr(it) =  .5   ! Lessivage du Pb210
+      DO i = 1,klon
+        masktr(i,it) = 1. ! Le depot sec peut avoir lieu partout
+        fshtr(i,it) = s * masktr(i,it)
+      END DO
+      print*, '-------------- SOURCE DU PLOMB ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir : ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+c
+      WRITE(*,*) 'initialisation rnpb ok'
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/interfoce_lim.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/interfoce_lim.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/interfoce_lim.F90	(revision 984)
@@ -0,0 +1,289 @@
+!
+! $Header$
+!
+SUBROUTINE interfoce_lim(itime, dtime, jour, &
+     knon, knindex, &
+     debut,  &
+     lmt_sst_p, pctsrf_new_p)
+  
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  
+  IMPLICIT NONE
+  
+  INCLUDE "indicesol.h"
+  INCLUDE "netcdf.inc"
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst_p      SST lues dans le fichier de CL
+!   pctsrf_new-p   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+!****************************************************************************************
+  INTEGER, INTENT(IN)                       :: itime
+  INTEGER, INTENT(IN)                       :: jour
+  INTEGER, INTENT(IN)                       :: knon
+  INTEGER, DIMENSION(klon_loc), INTENT(IN)  :: knindex
+  REAL   , INTENT(IN)                       :: dtime
+  LOGICAL, INTENT(IN)                       :: debut
+  
+! Parametres de sortie
+!****************************************************************************************
+  REAL, INTENT(OUT), DIMENSION(klon_loc)       :: lmt_sst_p
+  REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p
+
+
+! Variables locales avec l'attribut SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+  INTEGER,SAVE                              :: lmt_pas   
+  !$OMP THREADPRIVATE(lmt_pas)
+! pour indiquer que le jour a lire est deja lu pour une surface precedente
+  LOGICAL,SAVE                              :: deja_lu   
+  !$OMP THREADPRIVATE(deja_lu)
+  INTEGER,SAVE                              :: jour_lu 
+  !$OMP THREADPRIVATE(jour_lu)
+  CHARACTER (len = 20),SAVE                 :: fich ='limit.nc'
+  !$OMP THREADPRIVATE(fich)
+  LOGICAL, SAVE                             :: newlmt = .TRUE.
+  !$OMP THREADPRIVATE(newlmt)
+  LOGICAL, SAVE                             :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:)    :: sst_lu_p
+  !$OMP THREADPRIVATE(sst_lu_p)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:,:)  :: pct_tmp_p
+  !$OMP THREADPRIVATE(pct_tmp_p)
+
+! Variables locales 
+!****************************************************************************************
+  INTEGER                                   :: nid, nvarid
+  INTEGER                                   :: ii
+  INTEGER                                   :: ierr
+  INTEGER, DIMENSION(2)                     :: start, epais
+  CHARACTER (len = 20)                      :: modname = 'interfoce_lim'
+  CHARACTER (len = 80)                      :: abort_message
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pctsrf_new
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pct_tmp
+  REAL, DIMENSION(klon_glo)                 :: sst_lu
+  REAL, DIMENSION(klon_glo)                 :: nat_lu
+!
+! Fin declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! Start calculation
+!
+!****************************************************************************************
+  IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN
+     lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+     jour_lu = jour - 1
+     ALLOCATE(sst_lu_p(klon_loc))
+     ALLOCATE(pct_tmp_p(klon_loc,nbsrf))
+  ENDIF
+  
+  IF ((jour - jour_lu) /= 0) deja_lu = .FALSE.
+  
+  IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
+  IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime
+
+!****************************************************************************************
+! Ouverture et lecture du fichier pour le master process si c'est le bon moment
+!
+!****************************************************************************************
+! Tester d'abord si c'est le moment de lire le fichier
+  IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN
+
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+
+        fich = TRIM(fich)
+        ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+           abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+
+        ! La tranche de donnees a lire:
+
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+        IF (newlmt) THEN
+           !
+           ! Fraction "ocean" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FOCE> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FOCE>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glace de mer" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FSIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FSIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FTER> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FTER>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glacier terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FLIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FLIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+        ELSE  ! on en est toujours a rnatur
+           ! 
+           ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <NAT> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu)
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu)
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <NAT>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+!
+! Remplissage des fractions de surface
+! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
+! 
+           pct_tmp = 0.0
+           DO ii = 1, klon_glo
+              pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1.
+           ENDDO
+
+!
+!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
+!
+           pctsrf_new = pct_tmp
+           pctsrf_new (:,2)= pct_tmp (:,1)
+           pctsrf_new (:,1)= pct_tmp (:,2)
+           pct_tmp = pctsrf_new 
+        ENDIF ! fin test sur newlmt
+!
+! Lecture SST
+!
+        ierr = NF_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Le champ <SST> est absent'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu)
+#else
+        ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu)
+#endif
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Lecture echouee pour <SST>'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+          
+!****************************************************************************************
+! Fin de lecture, fermeture de fichier
+!
+!****************************************************************************************
+        ierr = NF_CLOSE(nid)
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+!****************************************************************************************
+! Distribue les variables sur tous les processus
+!
+!****************************************************************************************
+     CALL Scatter(sst_lu,sst_lu_p)
+     CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
+     CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
+     deja_lu = .TRUE.
+     jour_lu = jour
+  ENDIF
+
+!****************************************************************************************
+! Recopie des variables dans les champs de sortie
+!
+!****************************************************************************************
+  lmt_sst_p = 999999999.
+  
+  DO ii = 1, knon
+     lmt_sst_p(ii) = sst_lu_p(knindex(ii))
+  ENDDO
+  
+  DO ii=1,klon_loc
+     pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
+     pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
+  ENDDO
+  
+  
+END SUBROUTINE interfoce_lim
Index: LMDZ4/tags/LF_20080728/libf/phylmd/iophy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/iophy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/iophy.F90	(revision 984)
@@ -0,0 +1,188 @@
+!
+! $Header$
+!
+module iophy
+  
+  REAL,private,allocatable,dimension(:,:),save :: tmp_tab2d
+  REAL,private,allocatable,dimension(:,:,:),save :: tmp_tab3d
+  INTEGER,private,allocatable,dimension(:),save :: ndex2d
+  INTEGER,private,allocatable,dimension(:),save :: ndex3d
+! abd  REAL,private,allocatable,dimension(:),save :: io_lat
+! abd  REAL,private,allocatable,dimension(:),save :: io_lon
+  REAL,allocatable,dimension(:),save :: io_lat
+  REAL,allocatable,dimension(:),save :: io_lon
+  INTEGER, save :: phys_domain_id
+  
+  INTERFACE histwrite_phy
+    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
+  END INTERFACE 
+
+contains
+
+  subroutine init_iophy(lat,lon)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  implicit none
+  include 'dimensions.h'   
+    real,dimension(iim),intent(in) :: lon
+    real,dimension(jjm+1-1/iim),intent(in) :: lat
+
+    INTEGER,DIMENSION(2) :: ddid
+    INTEGER,DIMENSION(2) :: dsg
+    INTEGER,DIMENSION(2) :: dsl
+    INTEGER,DIMENSION(2) :: dpf
+    INTEGER,DIMENSION(2) :: dpl
+    INTEGER,DIMENSION(2) :: dhs
+    INTEGER,DIMENSION(2) :: dhe 
+
+!$OMP MASTER  
+    allocate(io_lat(jjm+1-1/iim))
+    io_lat(:)=lat(:)
+    allocate(io_lon(iim))
+    io_lon(:)=lon(:)
+    allocate(tmp_tab2d(iim,jj_nb))
+    allocate(tmp_tab3d(iim,jj_nb,klev))
+    allocate(ndex2d(iim*jj_nb))
+    allocate(ndex3d(iim*jj_nb*klev))
+    ndex2d(:)=0
+    ndex3d(:)=0
+    
+    ddid=(/ 1,2 /)
+    dsg=(/ iim, jjm+1-1/iim /)
+    dsl=(/ iim, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',phys_domain_id)
+
+!$OMP END MASTER
+      
+  end subroutine init_iophy
+  
+  subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  use write_field
+  implicit none
+  include 'dimensions.h'
+    
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau0
+    real,intent(in) :: zjulian
+    real,intent(in) :: dtime
+    integer,intent(out) :: nhori
+    integer,intent(out) :: nid_day
+
+!$OMP MASTER    
+    if (is_sequential) then
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
+    else
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
+    endif
+!$OMP END MASTER
+  
+  end subroutine histbeg_phy
+  
+  subroutine histwrite2d_phy(nid,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  implicit none
+  include 'dimensions.h'
+    
+    integer,intent(in) :: nid
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(klon),intent(in) :: field
+    
+    REAL,dimension(klon_mpi) :: buffer_omp
+    
+    CALL Gather_omp(field,buffer_omp)    
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,tmp_tab2d)
+    CALL histwrite(nid,name,itau,tmp_tab2d,iim*jj_nb,ndex2d)
+!$OMP END MASTER    
+  end subroutine histwrite2d_phy
+  
+  subroutine histwrite3d_phy(nid,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+
+  use ioipsl
+  implicit none
+  include 'dimensions.h'
+    
+    integer,intent(in) :: nid
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(klon,klev),intent(in) :: field
+
+    REAL,dimension(klon_mpi,klev) :: buffer_omp
+    
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,tmp_tab3d)
+    CALL histwrite(nid,name,itau,tmp_tab3d,iim*jj_nb*klev,ndex3d)
+!$OMP END MASTER    
+  end subroutine histwrite3d_phy
+  
+  
+!  subroutine phy2dyn(field_phy,field_dyn,nlev)
+!  USE dimphy_old
+!  implicit none
+!  include 'dimensions.h'
+!  
+!    real,dimension(klon_mpi,nlev),intent(in) :: field_phy
+!    real,dimension(iim,jjphy_nb,nlev),intent(out) :: field_dyn
+!    integer,intent(in) :: nlev
+!    
+!    integer :: next
+!    integer :: j,l
+!    
+!      do l=1,nlev
+!        	
+!	if (jjphy_begin==jjphy_end) then
+!	  field_dyn(:,1,l)=0.
+!	  field_dyn(iiphy_begin:iiphy_end,1,l)=field_phy(1:klon_mpi,l)
+!	else
+!	
+!	 if (jjphy_begin==1) then
+!	    field_dyn(:,1,l)=field_phy(1,l)
+!	    next=2
+!	 else
+!	   field_dyn(:,1,l)=0.
+!	   next=iim-iiphy_begin+2
+!	   field_dyn(iiphy_begin:iim,1,l)=field_phy(1:next-1,l)   
+!	 endif
+!	
+!	  do j=2,jjphy_nb-1
+!	    field_dyn(:,j,l)=field_phy(next:next+iim-1,l)
+!	    next=next+iim
+!	  enddo
+!	  
+!	  if (jjphy_end==jjm+1-1/iim) then
+!             field_dyn(:,jjphy_nb,l)=field_phy(klon_mpi,l)
+!	  else
+!	   field_dyn(:,jjphy_nb,l)=0.
+!	   field_dyn(1:iiphy_end,jjphy_nb,l)=field_phy(next:next+iiphy_end-1,l)   
+!	  endif
+!	  
+!	endif
+!     
+!     enddo
+!	 
+!    end subroutine phy2dyn	    
+  
+	  
+end module iophy
Index: LMDZ4/tags/LF_20080728/libf/phylmd/isccp_cloud_types.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/isccp_cloud_types.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/isccp_cloud_types.F	(revision 984)
@@ -0,0 +1,1668 @@
+!
+! $Header$
+!
+      SUBROUTINE ISCCP_CLOUD_TYPES(
+     &     debug,
+     &     debugcol,
+     &     npoints,
+     &     sunlit,
+     &     nlev,
+     &     ncol,
+     &     seed,
+     &     pfull,
+     &     phalf,
+     &     qv,
+     &     cc,
+     &     conv,
+     &     dtau_s,
+     &     dtau_c,
+     &     top_height,
+     &     overlap,
+     &     tautab,
+     &     invtau,
+     &     skt,
+     &     emsfc_lw,
+     &     at,dem_s,dem_c,
+     &     fq_isccp,
+     &     totalcldarea,
+     &     meanptop,
+     &     meantaucld,
+     &     boxtau,
+     &     boxptop
+     &)
+	
+
+! Copyright Steve Klein and Mark Webb 2002 - all rights reserved.
+!
+! This code is available without charge with the following conditions:
+!
+!  1. The code is available for scientific purposes and is not for 
+!     commercial use.
+!  2. Any improvements you make to the code should be made available 
+!     to the to the authors for incorporation into a future release.
+!  3. The code should not be used in any way that brings the authors 
+!     or their employers into disrepute.
+
+      implicit none
+
+!     NOTE:   the maximum number of levels and columns is set by
+!             the following parameter statement
+
+      INTEGER ncolprint
+      
+!     -----
+!     Input 
+!     -----
+
+      INTEGER npoints                   !  number of model points in the horizontal
+c      PARAMETER(npoints=6722)
+      INTEGER nlev                      !  number of model levels in column
+      INTEGER ncol                      !  number of subcolumns
+
+      INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
+
+      INTEGER seed(npoints)             !  seed value for random number generator
+c                                       !  ( see Numerical Recipes Chapter 7)
+c                                       !  It is recommended that the seed is set
+c                                       !  to a different value for each model
+c                                       !  gridbox it is called on, as it is 
+c          				!  possible that the choice of the samec 
+c					!  seed value every time may introduce some
+c					!  statistical bias in the results, particularly
+c					!  for low values of NCOL.
+c
+      REAL pfull(npoints,nlev)	      	!  pressure of full model levels (Pascals)
+c                                        !  pfull(npoints,1)    is    top level of model
+c                                        !  pfull(npoints,nlev) is bottom level of model
+
+      REAL phalf(npoints,nlev+1)        !  pressure of half model levels (Pascals)
+c                                        !  phalf(npoints,1)    is    top       of model
+c                                        !  phalf(npoints,nlev+1) is the surface pressure
+
+      REAL qv(npoints,nlev)             !  water vapor specific humidity (kg vapor/ kg air)
+c                                        !         on full model levels
+
+      REAL cc(npoints,nlev)             !  input cloud cover in each model level (fraction) 
+c                                        !  NOTE:  This is the HORIZONTAL area of each
+c                                        !         grid box covered by clouds
+
+      REAL conv(npoints,nlev)           !  input convective cloud cover in each model level (fraction) 
+c                                        !  NOTE:  This is the HORIZONTAL area of each
+c                                        !         grid box covered by convective clouds
+
+      REAL dtau_s(npoints,nlev)         !  mean 0.67 micron optical depth of stratiform
+c					!  clouds in each model level
+c                                        !  NOTE:  this the cloud optical depth of only the
+c                                        !         cloudy part of the grid box, it is not weighted
+c                                        !         with the 0 cloud optical depth of the clear
+c                                        !         part of the grid box
+
+      REAL dtau_c(npoints,nlev)         !  mean 0.67 micron optical depth of convective
+c					!  clouds in each
+c                                        !  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
+c                                        !  infrared brightness temperature and the visible
+c					!  optical depth to adjust cloud top pressure. Note
+c					!  that this calculation is most appropriate to compare
+c					!  to ISCCP data during sunlit hours.
+c                                        !  2 = do not adjust top height, that is cloud top
+c                                        !  pressure is the actual cloud top pressure
+c                                        !  in the model
+c					!  3 = adjust top height using only the computed
+c					!  infrared brightness temperature. Note that this
+c					!  calculation is most appropriate to compare to ISCCP
+c					!  IR only algortihm (i.e. you can compare to nighttime
+c					!  ISCCP data with this option)
+
+      REAL tautab(0:255)                !  ISCCP table for converting count value to 
+c                                        !  optical thickness
+
+      INTEGER invtau(-20:45000)         !  ISCCP table for converting optical thickness 
+c                                        !  to count value
+!
+!     The following input variables are used only if top_height = 1 or top_height = 3
+!
+      REAL skt(npoints)                 !  skin Temperature (K)
+      REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)                                            
+      REAL at(npoints,nlev)                   !  temperature in each model level (K)
+      REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
+c					!  clouds in each
+c                                        !  model level.  Same note applies as in dtau_s.
+      REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
+c					!  clouds in each
+c                                        !  model level.  Same note applies as in dtau_s.
+cIM reg.dyn BEG
+      REAL t1, t2
+!     REAL w(npoints)                   !vertical wind at 500 hPa
+!     LOGICAL pct_ocean(npoints)        !TRUE if oceanic point, FALSE otherway
+!     INTEGER iw(npoints) , nw
+!     REAL wmin, pas_w
+!     INTEGER k, l, iwmx
+!     PARAMETER(wmin=-100.,pas_w=10.,iwmx=30)
+!     REAL fq_dynreg(7,7,iwmx)
+!     REAL nfq_dynreg(7,7,iwmx) 
+!     LOGICAL pctj(7,7,iwmx)
+cIM reg.dyn END
+!     ------
+!     Output
+!     ------
+
+      REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
+c                                        !  each of the 49 ISCCP D level cloud types
+
+      REAL totalcldarea(npoints)        !  the fraction of model grid box columns
+c                                        !  with cloud somewhere in them.  This should
+c					!  equal the sum over all entries of fq_isccp
+	
+	
+c      ! The following three means are averages over the cloudy areas only.  If no
+c      ! clouds are in grid box all three quantities should equal zero.	
+					
+      REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
+c                                        !  in cloud top pressure.
+					
+      REAL meantaucld(npoints)          !  mean optical thickness 
+c                                        !  linear averaging in albedo performed.
+      
+      REAL boxtau(npoints,ncol)         !  optical thickness in each column
+      
+      REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
+					
+															
+!
+!     ------
+!     Working variables added when program updated to mimic Mark Webb's PV-Wave code
+!     ------
+
+      REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
+c					! Equivalent of BOX in original version, but
+c					! indexed by column then row, rather than
+c					! by row then column
+
+      REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction)
+c                                        ! with extra layer of zeroes on top
+c                                        ! in this version this just contains the values input
+c                                        ! from cc but with an extra level
+      REAL cca(npoints,nlev)         ! convective cloud cover in each model level (fraction)
+c                                        ! from conv 
+
+      REAL threshold(npoints,ncol)   ! pointer to position in gridbox
+      REAL maxocc(npoints,ncol)      ! Flag for max overlapped conv cld
+      REAL maxosc(npoints,ncol)      ! Flag for max overlapped strat cld
+
+      REAL boxpos(npoints,ncol)      ! ordered pointer to position in gridbox
+
+      REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold
+c                                        ! is chosen
+
+      REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave 
+c					!  emissivity in part of
+c					!  gridbox under consideration
+
+      REAL ran(npoints)   	        ! vector of random numbers
+      REAL ptrop(npoints)
+      REAL attrop(npoints)
+      REAL attropmin (npoints)
+      REAL atmax(npoints)
+      REAL atmin(npoints)
+      REAL btcmin(npoints)
+      REAL transmax(npoints)
+
+      INTEGER i,j,ilev,ibox,itrop(npoints)
+      INTEGER ipres(npoints)
+      INTEGER itau(npoints),ilev2
+      INTEGER acc(nlev,ncol)
+      INTEGER match(npoints,nlev-1)
+      INTEGER nmatch(npoints)
+      INTEGER levmatch(npoints,ncol)
+      
+c      !variables needed for water vapor continuum absorption
+      real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
+      real taumin(npoints)
+      real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
+      real press(npoints), dpress(npoints), atmden(npoints)
+      real rvh20(npoints), wk(npoints), rhoave(npoints)
+      real rh20s(npoints), rfrgn(npoints)
+      real tmpexp(npoints),tauwv(npoints)
+      
+      character*1 cchar(6),cchar_realtops(6)
+      integer icycle
+      REAL tau(npoints,ncol)
+      LOGICAL box_cloudy(npoints,ncol)
+      REAL tb(npoints,ncol)
+      REAL ptop(npoints,ncol)
+      REAL emcld(npoints,ncol)
+      REAL fluxtop(npoints,ncol)
+      REAL trans_layers_above(npoints,ncol)
+      real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
+      real meanalbedocld(npoints) 
+      REAL albedocld(npoints,ncol)
+      real boxarea
+      integer debug       ! set to non-zero value to print out inputs
+c			  ! with step debug
+      integer debugcol    ! set to non-zero value to print out column
+c			  ! decomposition with step debugcol
+
+      integer index1(npoints),num1,jj
+      real rec2p13,tauchk
+
+      character*10 ftn09
+      
+      DATA isccp_taumin / 0.3 /
+      DATA cchar / ' ','-','1','+','I','+'/
+      DATA cchar_realtops / ' ',' ','1','1','I','I'/
+
+      tauchk = -1.*log(0.9999999)
+      rec2p13=1./2.13
+
+      ncolprint=0
+
+cIM
+c     PRINT*,' isccp_cloud_types npoints=',npoints
+c
+c      if ( debug.ne.0 ) then
+c          j=1
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write(6,'(a10)') 'debug='
+c          write(6,'(8I10)') debug
+c          write(6,'(a10)') 'debugcol='
+c          write(6,'(8I10)') debugcol
+c          write(6,'(a10)') 'npoints='
+c          write(6,'(8I10)') npoints
+c          write(6,'(a10)') 'nlev='
+c          write(6,'(8I10)') nlev
+c          write(6,'(a10)') 'ncol='
+c          write(6,'(8I10)') ncol
+c          write(6,'(a10)') 'top_height='
+c          write(6,'(8I10)') top_height
+c          write(6,'(a10)') 'overlap='
+c          write(6,'(8I10)') overlap
+c          write(6,'(a10)') 'emsfc_lw='
+c          write(6,'(8f10.2)') emsfc_lw
+c          write(6,'(a10)') 'tautab='
+c          write(6,'(8f10.2)') tautab
+c          write(6,'(a10)') 'invtau(1:100)='
+c          write(6,'(8i10)') (invtau(i),i=1,100)
+c	  do j=1,npoints,debug
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write(6,'(a10)') 'sunlit='
+c          write(6,'(8I10)') sunlit(j)
+c          write(6,'(a10)') 'seed='
+c          write(6,'(8I10)') seed(j)
+c          write(6,'(a10)') 'pfull='
+c          write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
+c          write(6,'(a10)') 'phalf='
+c          write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
+c          write(6,'(a10)') 'qv='
+c          write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
+c          write(6,'(a10)') 'cc='
+c          write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
+c          write(6,'(a10)') 'conv='
+c          write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dtau_s='
+c          write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dtau_c='
+c          write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
+c          write(6,'(a10)') 'skt='
+c          write(6,'(8f10.2)') skt(j)
+c          write(6,'(a10)') 'at='
+c          write(6,'(8f10.2)') (at(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dem_s='
+c          write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dem_c='
+c          write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev)
+c	  enddo
+c      endif
+
+!     ---------------------------------------------------!
+
+!     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
+
+!     assign 2d cca array using 1d input array conv
+
+      do ilev=1,nlev
+cIM pas besoin        do ibox=1,ncol
+          do j=1,npoints
+            cca(j,ilev)=conv(j,ilev)
+          enddo
+cIM        enddo
+      enddo
+
+cIM
+!     do j=1, iwmx
+!     do l=1, 7
+!     do k=1, 7
+!       fq_dynreg(k,l,j) =0. 
+!       nfq_dynreg(k,l,j) =0. 
+!      enddo !k
+!     enddo !l
+!     enddo !j
+cIM
+cIM
+c      if (ncolprint.ne.0) then
+c	do j=1,npoints,1000
+c        write(6,'(a10)') 'j='
+c        write(6,'(8I10)') j
+c        write (6,'(a)') 'seed:'
+c        write (6,'(I3.2)') seed(j)
+
+c        write (6,'(a)') 'tca_pp_rev:'
+c        write (6,'(8f5.2)') 
+c     &   ((tca(j,ilev)),
+c     &      ilev=1,nlev)
+
+c        write (6,'(a)') 'cca_pp_rev:'
+c        write (6,'(8f5.2)') 
+c     &   ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev)
+c	enddo
+c      endif
+
+      if (top_height .eq. 1 .or. top_height .eq. 3) then 
+
+      do j=1,npoints 
+          ptrop(j)=5000.
+          atmin(j) = 400.
+          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
+           if (at(j,ilev) .gt. atmax(j)) atmax(j)=at(j,ilev)
+           if (at(j,ilev) .lt. atmin(j)) atmin(j)=at(j,ilev)
+        enddo
+12    continue
+
+      end if
+
+!     -----------------------------------------------------!
+
+!     ---------------------------------------------------!
+
+cIM
+c     do 13 ilev=1,nlev
+cnum1=0
+c       do j=1,npoints
+c           if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  ' error = cloud fraction less than zero'
+c	write(6,*) ' or '
+c               write(6,*)  ' error = cloud fraction greater than 1'
+c	write(6,*) 'value at point ',j,' is ',cc(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+cnum1=0
+c       do j=1,npoints
+c           if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud fraction less than zero'
+c	write(6,*) ' or '
+c               write(6,*)  
+c    &           ' error = convective cloud fraction greater than 1'
+c	write(6,*) 'value at point ',j,' is ',conv(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dtau_s(j,ilev) .lt. 0.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = stratiform cloud opt. depth less than zero'
+c	write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+cnum1=0
+c       do j=1,npoints
+c           if (dtau_c(j,ilev) .lt. 0.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud opt. depth less than zero'
+c	write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = stratiform cloud emissivity less than zero'
+c	write(6,*)'or'
+c               write(6,*)  
+c    &           ' error = stratiform cloud emissivity greater than 1'
+c	write(6,*) 'value at point ',j,' is ',dem_s(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud emissivity less than zero'
+c	write(6,*)'or'
+c               write(6,*)  
+c    &           ' error = convective cloud emissivity greater than 1'
+c               write (6,*) 
+c    &          'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev) 
+c               STOP
+c       enddo
+c13    continue
+
+
+      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 ibox=1,ncol
+        do ilev=1,nlev
+          do j=1,npoints
+	    frac_out(j,ibox,ilev)=0.0
+          enddo
+        enddo
+      enddo
+
+cIM
+c      if (ncolprint.ne.0) then
+c        write (6,'(a)') 'frac_out_pp_rev:'
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(8f5.2)') 
+c     &     ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
+
+c          enddo
+c        write (6,'(a)') 'ncol:'
+c        write (6,'(I3)') ncol
+c      endif
+c      if (ncolprint.ne.0) then
+c        write (6,'(a)') 'last_frac_pp:'
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(8f5.2)') (tca(j,0))
+c          enddo
+c      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
+                call ran0_vec(npoints,seed,ran)
+	        ! select random pixels from the non-convective
+	        ! part the gridbox ( some will be converted into
+	        ! convective pixels below )
+                do j=1,npoints
+                  threshold(j,ibox)=
+     &            cca(j,ilev)+(1-cca(j,ilev))*ran(j)
+                enddo
+              enddo
+            ENDIF
+cIM
+c            IF (ncolprint.ne.0) then
+c              write (6,'(a)') 'threshold_nsf2:'
+c                do j=1,npoints,1000
+c                write(6,'(a10)') 'j='
+c                write(6,'(8I10)') j
+c                write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+c                enddo
+c            ENDIF
+        ENDIF
+
+c        IF (ncolprint.ne.0) then
+c            write (6,'(a)') 'ilev:'
+c            write (6,'(I2)') ilev
+c        ENDIF
+
+        DO ibox=1,ncol
+
+          ! All versions
+          do j=1,npoints
+            if (boxpos(j,ibox).le.cca(j,ilev)) then
+cIM REAL           maxocc(j,ibox) = 1
+              maxocc(j,ibox) = 1.0
+            else
+cIM REAL           maxocc(j,ibox) = 0
+              maxocc(j,ibox) = 0.0
+            end if
+          enddo
+
+          ! Max overlap
+          if (overlap.eq.1) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=cca(j,ilev)
+cIM REAL           maxosc(j,ibox)=1
+              maxosc(j,ibox)=1.0
+            enddo
+          endif
+
+          ! Random overlap
+          if (overlap.eq.2) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=cca(j,ilev)
+cIM REAL           maxosc(j,ibox)=0
+              maxosc(j,ibox)=0.0
+            enddo
+          endif
+
+          ! Max/Random overlap
+          if (overlap.eq.3) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=max(cca(j,ilev),
+     &          min(tca(j,ilev-1),tca(j,ilev)))
+              if (threshold(j,ibox)
+     &          .lt.min(tca(j,ilev-1),tca(j,ilev))
+     &          .and.(threshold(j,ibox).gt.cca(j,ilev))) then
+cIM REAL                maxosc(j,ibox)= 1
+                   maxosc(j,ibox)= 1.0
+              else
+cIM REAL                 maxosc(j,ibox)= 0
+                   maxosc(j,ibox)= 0.0
+              end if
+            enddo
+          endif
+    
+          ! Reset threshold 
+          call ran0_vec(npoints,seed,ran)
+	   
+          do j=1,npoints
+            threshold(j,ibox)=
+              !if max overlapped conv cloud
+     &        maxocc(j,ibox) * (                                       
+     &            boxpos(j,ibox)                                               
+     &        ) +                                                      
+              !else
+     &        (1-maxocc(j,ibox)) * (                                   
+                  !if max overlapped strat cloud
+     &            (maxosc(j,ibox)) * (                                 
+                      !threshold=boxpos
+     &                threshold(j,ibox)                                        
+     &            ) +                                                  
+                  !else
+     &            (1-maxosc(j,ibox)) * (                               
+                      !threshold_min=random[thrmin,1]
+     &                threshold_min(j,ibox)+
+     &                  (1-threshold_min(j,ibox))*ran(j)  
+     &           ) 
+     &        )
+          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
+cIM REAL             frac_out(j,ibox,ilev)=1
+               frac_out(j,ibox,ilev)=1.0
+               else
+cIM REAL             frac_out(j,ibox,ilev)=0
+               frac_out(j,ibox,ilev)=0.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.cca(j,ilev)) then
+                    ! = 2 IF threshold le cca(j)
+cIM REAL                  frac_out(j,ibox,ilev) = 2 
+                    frac_out(j,ibox,ilev) = 2.0 
+                else
+                    ! = the same IF NOT threshold le cca(j) 
+                    frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev)
+                end if
+             enddo
+           ENDDO
+
+!         Set last_frac to tca at this level, so as to be tca 
+!         from last level next time round
+
+cIM
+c          if (ncolprint.ne.0) then
+
+c            do j=1,npoints ,1000
+c            write(6,'(a10)') 'j='
+c            write(6,'(8I10)') j
+c            write (6,'(a)') 'last_frac:'
+c            write (6,'(8f5.2)') (tca(j,ilev-1))
+    
+c            write (6,'(a)') 'cca:'
+c            write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'max_overlap_cc:'
+c            write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'max_overlap_sc:'
+c            write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'threshold_min_nsf2:'
+c            write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'threshold_nsf2:'
+c            write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'frac_out_pp_rev:'
+c            write (6,'(8f5.2)') 
+c     &       ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+c	    enddo
+c          endif
+
+200   CONTINUE    !loop over nlev
+
+!
+!     ---------------------------------------------------!
+
+      
+!
+!     ---------------------------------------------------!
+!     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)=0.
+	    boxptop(j,ibox)=0.
+	    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 
+cIM REAL              if (frac_out(j,ibox,ilev).eq.1) then
+                 if (frac_out(j,ibox,ilev).eq.1.0) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_s(j,ilev)
+                 endif
+cIM REAL              if (frac_out(j,ibox,ilev).eq.2) then
+                 if (frac_out(j,ibox,ilev).eq.2.0) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_c(j,ilev)
+                 end if
+              enddo
+            enddo ! ibox
+      enddo ! ilev
+cIM
+c          if (ncolprint.ne.0) then
+
+c              do j=1,npoints ,1000
+c                write(6,'(a10)') 'j='
+c                write(6,'(8I10)') j
+c                write(6,'(i2,1X,8(f7.2,1X))') 
+c     &          ilev,
+c     &          (tau(j,ibox),ibox=1,ncolprint)
+c              enddo
+c          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.
+cIM
+c        if (ncolprint .ne. 0) 
+c     &         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
+cIM
+c               if (ncolprint .ne. 0) then
+c               do j=1,npoints ,1000
+c               write(6,'(a10)') 'j='
+c               write(6,'(8I10)') j
+c               write(6,'(i2,1X,3(f8.3,3X))') ilev,
+c     &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
+c     &           tauwv(j),dem_wv(j,ilev)
+c               enddo
+c	       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 
+cIM  
+c            if (ncolprint.ne.0) then
+c             do j=1,npoints ,1000
+c              write(6,'(a10)') 'j='
+c              write(6,'(8I10)') j
+c              write (6,'(a)') 'ilev:'
+c              write (6,'(I2)') ilev
+    
+c              write (6,'(a)') 
+c     &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
+c              write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
+c     &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
+c             enddo   
+c            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)
+        enddo
+
+cIM
+c        if (ncolprint.ne.0) then
+c        do j=1,npoints ,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(a)') 'id:'
+c          write (6,'(a)') 'surface'
+
+c          write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
+c          write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j),
+c     &      100.*fluxtop_clrsky(j),
+c     &       trans_layers_above_clrsky(j)
+c        enddo
+c	endif
+    
+
+        !
+        !           END OF CLEAR SKY CALCULATION
+        !
+        !----------------------------------------------------------------
+
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c        do j=1,npoints ,1000
+c            write(6,'(a10)') 'j='
+c            write(6,'(8I10)') j
+c            write (6,'(a)') 'ts:'
+c            write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'ta_rev:'
+c            write (6,'(8f7.2)') 
+c     &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+
+c        enddo
+c        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
+cIM REAL             if (frac_out(j,ibox,ilev).eq.1) then
+                if (frac_out(j,ibox,ilev).eq.1.0) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
+cIM REAL             else if (frac_out(j,ibox,ilev).eq.2) then
+                else if (frac_out(j,ibox,ilev).eq.2.0) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
+                else
+                dem(j,ibox)=  dem_wv(j,ilev)
+                end if
+                
+
+                ! increase TOA flux by flux emitted from layer
+	        ! times total transmittance in layers above
+
+                fluxtop(j,ibox) = fluxtop(j,ibox) 
+     &            + dem(j,ibox) * bb(j)
+     &            * trans_layers_above(j,ibox) 
+            
+                ! update trans_layers_above with transmissivity
+	        ! from this layer for next time around loop
+
+                trans_layers_above(j,ibox)=
+     &            trans_layers_above(j,ibox)*(1.-dem(j,ibox))
+
+              enddo ! j
+            enddo ! ibox
+
+cIM
+c            if (ncolprint.ne.0) then
+c              do j=1,npoints,1000
+c              write (6,'(a)') 'ilev:'
+c              write (6,'(I2)') ilev
+    
+c              write(6,'(a10)') 'j='
+c              write(6,'(8I10)') j
+c              write (6,'(a)') 'emiss_layer:'
+c              write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
+        
+c              write (6,'(a)') '100.*bb(j):'
+c              write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+        
+c              write (6,'(a)') '100.*f:'
+c              write (6,'(8f7.2)') 
+c     &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+        
+c              write (6,'(a)') 'total_trans:'
+c              write (6,'(8f7.2)') 
+c     &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
+c	      enddo
+c          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
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c          do j=1,npoints ,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(a)') 'id:'
+c          write (6,'(a)') 'surface'
+
+c          write (6,'(a)') 'emiss_layer:'
+c          write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') '100.*bb(j):'
+c          write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+    
+c          write (6,'(a)') '100.*f:'
+c          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+c          end do
+c	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
+                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) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
+            end if
+          enddo ! j
+        enddo ! ibox
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+
+c          write (6,'(a)') 'attrop:'
+c          write (6,'(8f7.2)') (attrop(j))
+    
+c          write (6,'(a)') 'btcmin:'
+c          write (6,'(8f7.2)') (btcmin(j))
+    
+c          write (6,'(a)') 'fluxtop_clrsky*100:'
+c          write (6,'(8f7.2)') 
+c     &      (100.*fluxtop_clrsky(j))
+
+c          write (6,'(a)') '100.*f_adj:'
+c          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'transmax:'
+c          write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'tau:'
+c          write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'emcld:'
+c          write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_trans:'
+c          write (6,'(8f7.2)') 
+c     &	  (trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_emiss:'
+c          write (6,'(8f7.2)') 
+c     &	  (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_trans:'
+c          write (6,'(8f7.2)') 
+c     &	  (trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'ppout:'
+c          write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+c          enddo ! j
+c	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 ilev=1,nlev-1
+            !cdir nodep
+            do j=1,npoints 
+              if ((at(j,ilev)   .ge. tb(j,ibox) .and. 
+     &          at(j,ilev+1) .lt. tb(j,ibox)) .or.
+     &          (at(j,ilev) .le. tb(j,ibox) .and. 
+     &          at(j,ilev+1) .gt. tb(j,ibox))) then 
+   
+                nmatch(j)=nmatch(j)+1
+                if(abs(at(j,ilev)-tb(j,ibox)) .lt.
+     &            abs(at(j,ilev+1)-tb(j,ibox))) then
+                  match(j,nmatch(j))=ilev
+                else
+                  match(j,nmatch(j))=ilev+1
+                end if
+              end if                        
+            enddo
+29        continue
+
+          do j=1,npoints 
+            if (nmatch(j) .ge. 1) then
+              ptop(j,ibox)=pfull(j,match(j,nmatch(j)))
+              levmatch(j,ibox)=match(j,nmatch(j))   
+            else
+              if (tb(j,ibox) .lt. atmin(j)) then
+                ptop(j,ibox)=ptrop(j)
+                levmatch(j,ibox)=itrop(j)
+              end if
+              if (tb(j,ibox) .gt. 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. )
+cIM  &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
+     &           .and.(frac_out(j,ibox,ilev) .ne. 0.0)) then
+                ptop(j,ibox)=pfull(j,ilev)
+	        levmatch(j,ibox)=ilev
+              end if
+            end do
+          end do
+        end if                            
+          
+        do j=1,npoints
+          if (tau(j,ibox) .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 ! 
+             fq_isccp(j,ilev,ilev2)=0.
+        enddo
+38    continue
+
+      !reset variables need for averaging cloud properties
+      do j=1,npoints 
+        totalcldarea(j) = 0.
+        meanalbedocld(j) = 0.
+        meanptop(j) = 0.
+        meantaucld(j) = 0.
+      enddo ! j
+
+      boxarea = 1./real(ncol)
+     
+              !determine optical depth category
+cIM       do 39 j=1,npoints
+cIM       do ibox=1,ncol
+        do 39 ibox=1,ncol
+          do j=1,npoints
+
+cIM
+c         CALL CPU_time(t1)
+cIM
+
+          if (tau(j,ibox) .gt. (tauchk            )
+     &      .and. ptop(j,ibox) .gt. 0.) then
+              box_cloudy(j,ibox)=.true.
+          endif
+
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF tau t2 - t1',t2 - t1
+
+c         CALL CPU_time(t1)
+cIM
+
+          if (box_cloudy(j,ibox)) then
+
+              ! totalcldarea always diagnosed day or night
+              totalcldarea(j) = totalcldarea(j) + boxarea
+
+              if (sunlit(j).eq.1) then
+
+                ! tau diagnostics only with sunlight
+
+                boxtau(j,ibox) = tau(j,ibox)
+
+                !convert optical thickness to albedo
+  	        albedocld(j,ibox)
+     &            =real(invtau(min(nint(100.*tau(j,ibox)),45000)))
+	    
+                !contribute to averaging
+	        meanalbedocld(j) = meanalbedocld(j) 
+     &            +albedocld(j,ibox)*boxarea
+
+            endif
+
+          endif
+          
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF box_cloudy t2 - t1',t2 - t1
+          
+c         CALL CPU_time(t1)
+cIM BEG 
+cIM           !convert ptop to millibars
+              ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+cIM           !save for output cloud top pressure and optical thickness
+              boxptop(j,ibox) = ptop(j,ibox)
+cIM END
+
+cIM BEG
+              !reset itau(j), ipres(j)
+              itau(j) = 0
+              ipres(j) = 0
+
+              if (tau(j,ibox) .lt. isccp_taumin) then
+                  itau(j)=1
+              else if (tau(j,ibox) .ge. isccp_taumin
+     &                                    
+     &          .and. tau(j,ibox) .lt. 1.3) then
+                itau(j)=2
+              else if (tau(j,ibox) .ge. 1.3 
+     &          .and. tau(j,ibox) .lt. 3.6) then
+                itau(j)=3
+              else if (tau(j,ibox) .ge. 3.6 
+     &          .and. tau(j,ibox) .lt. 9.4) then
+                  itau(j)=4
+              else if (tau(j,ibox) .ge. 9.4 
+     &          .and. tau(j,ibox) .lt. 23.) then
+                  itau(j)=5
+              else if (tau(j,ibox) .ge. 23. 
+     &          .and. tau(j,ibox) .lt. 60.) then
+                  itau(j)=6
+              else if (tau(j,ibox) .ge. 60.) then
+                  itau(j)=7
+              end if
+
+              !determine cloud top pressure category
+              if (    ptop(j,ibox) .gt. 0.  
+     &          .and.ptop(j,ibox) .lt. 180.) then
+                  ipres(j)=1
+              else if(ptop(j,ibox) .ge. 180.
+     &          .and.ptop(j,ibox) .lt. 310.) then
+                  ipres(j)=2
+              else if(ptop(j,ibox) .ge. 310.
+     &          .and.ptop(j,ibox) .lt. 440.) then
+                  ipres(j)=3
+              else if(ptop(j,ibox) .ge. 440.
+     &          .and.ptop(j,ibox) .lt. 560.) then
+                  ipres(j)=4
+              else if(ptop(j,ibox) .ge. 560.
+     &          .and.ptop(j,ibox) .lt. 680.) then
+                  ipres(j)=5
+              else if(ptop(j,ibox) .ge. 680.
+     &          .and.ptop(j,ibox) .lt. 800.) then
+                  ipres(j)=6
+              else if(ptop(j,ibox) .ge. 800.) then
+                  ipres(j)=7
+              end if 
+cIM END
+
+          if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
+
+cIM         !convert ptop to millibars
+cIM           ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+cIM         !save for output cloud top pressure and optical thickness
+cIM             boxptop(j,ibox) = ptop(j,ibox)
+    
+            if (box_cloudy(j,ibox)) then
+	    
+              meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
+
+cIM             !reset itau(j), ipres(j)
+cIM           itau(j) = 0
+cIM           ipres(j) = 0
+
+c             if (tau(j,ibox) .lt. isccp_taumin) then
+c                 itau(j)=1
+c             else if (tau(j,ibox) .ge. isccp_taumin
+c    &                                    
+c    &          .and. tau(j,ibox) .lt. 1.3) then
+c               itau(j)=2
+c             else if (tau(j,ibox) .ge. 1.3 
+c    &          .and. tau(j,ibox) .lt. 3.6) then
+c               itau(j)=3
+c             else if (tau(j,ibox) .ge. 3.6 
+c    &          .and. tau(j,ibox) .lt. 9.4) then
+c                 itau(j)=4
+c             else if (tau(j,ibox) .ge. 9.4 
+c    &          .and. tau(j,ibox) .lt. 23.) then
+c                 itau(j)=5
+c             else if (tau(j,ibox) .ge. 23. 
+c    &          .and. tau(j,ibox) .lt. 60.) then
+c                 itau(j)=6
+c             else if (tau(j,ibox) .ge. 60.) then
+c                 itau(j)=7
+c             end if
+
+c             !determine cloud top pressure category
+c             if (    ptop(j,ibox) .gt. 0.  
+c    &          .and.ptop(j,ibox) .lt. 180.) then
+c                 ipres(j)=1
+c             else if(ptop(j,ibox) .ge. 180.
+c    &          .and.ptop(j,ibox) .lt. 310.) then
+c                 ipres(j)=2
+c             else if(ptop(j,ibox) .ge. 310.
+c    &          .and.ptop(j,ibox) .lt. 440.) then
+c                 ipres(j)=3
+c            else if(ptop(j,ibox) .ge. 440.
+c    &          .and.ptop(j,ibox) .lt. 560.) then
+c                 ipres(j)=4
+c             else if(ptop(j,ibox) .ge. 560.
+c    &          .and.ptop(j,ibox) .lt. 680.) then
+c                 ipres(j)=5
+c             else if(ptop(j,ibox) .ge. 680.
+c    &          .and.ptop(j,ibox) .lt. 800.) then
+c                 ipres(j)=6
+c             else if(ptop(j,ibox) .ge. 800.) then
+c                 ipres(j)=7
+c             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
+
+cIM calcul stats regime dynamique BEG
+!             iw(j) = int((w(j)-wmin)/pas_w) +1
+!             pctj(itau(j),ipres(j),iw(j))=.FALSE.
+!             !update frequencies W500
+!             if (pct_ocean(j)) then
+!             if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+!             if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+c             print*,' ISCCP iw=',iw(j),j
+!             fq_dynreg(itau(j),ipres(j),iw(j))=
+!    &          fq_dynreg(itau(j),ipres(j),iw(j))+
+!    &          boxarea
+c    &          fq_isccp(j,itau(j),ipres(j))
+!             pctj(itau(j),ipres(j),iw(j))=.TRUE.
+c             nfq_dynreg(itau(j),ipres(j),iw(j))=
+c    &          nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+!              end if
+!             end if
+!             end if
+cIM calcul stats regime dynamique END
+            end if !IM boxcloudy
+
+          end if !IM sunlit
+                       
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF sunlit boxcloudy t2 - t1',t2 - t1
+cIM
+        enddo !IM ibox/j
+
+
+cIM ajout stats s/ W500 BEG
+cIM ajout stats s/ W500 END
+
+c             if(j.EQ.6722) then
+c             print*,' ISCCP',w(j),iw(j),ipres(j),itau(j)
+c             endif
+
+!     if (pct_ocean(j)) then
+!     if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+!     if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+!     if(pctj(itau(j),ipres(j),iw(j))) THEN 
+!         nfq_dynreg(itau(j),ipres(j),iw(j))=
+!    &    nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+c         if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND.
+c    &    iw(j).EQ.10) then
+c         PRINT*,' isccp AVANT',
+c    &    nfq_dynreg(itau(j),ipres(j),iw(j)),
+c    &    fq_dynreg(itau(j),ipres(j),iw(j))
+c         endif
+!     endif
+!     endif
+!     endif
+!     endif
+39    continue !IM j/ibox
+      
+      !compute mean cloud properties
+      do j=1,npoints 
+        if (totalcldarea(j) .gt. 0.) then
+ 	  meanptop(j) = meanptop(j) / totalcldarea(j)
+          if (sunlit(j).eq.1) then
+            meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
+	    meantaucld(j) = tautab(min(255,max(1,nint(meanalbedocld(j))))) 
+          end if
+        end if
+      enddo ! j
+!
+cIM ajout stats s/ W500 BEG
+!     do nw = 1, iwmx
+!     do l = 1, 7
+!     do k = 1, 7
+!       if (nfq_dynreg(k,l,nw).GT.0.) then
+!       fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw)
+c        if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then
+c        print*,' isccp APRES',nfq_dynreg(k,l,nw),
+c    &   fq_dynreg(k,l,nw)
+c        endif
+!       else
+!        if(fq_dynreg(k,l,nw).NE.0.) then
+!        print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw)
+!        endif 
+c        fq_dynreg(k,l,nw) = -1.E+20
+c        nfq_dynreg(k,l,nw) = 1.E+20
+!       end if 
+!     enddo !k
+!     enddo !l
+!     enddo !nw
+cIM ajout stats s/ W500 END
+!     ---------------------------------------------------!
+
+!     ---------------------------------------------------!
+!     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
+!
+!cIM
+c      if (debugcol.ne.0) then
+!     
+c         do j=1,npoints,debugcol
+
+c            !produce character output
+c            do ilev=1,nlev
+c              do ibox=1,ncol
+c                   acc(ilev,ibox)=0
+c              enddo
+c            enddo
+
+c            do ilev=1,nlev
+c              do ibox=1,ncol
+c                   acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
+c                   if (levmatch(j,ibox) .eq. ilev) 
+c     &                 acc(ilev,ibox)=acc(ilev,ibox)+1
+c              enddo
+c            enddo
+
+             !print test
+
+c          write(ftn09,11) j
+c11        format('ftn09.',i4.4)
+c         open(9, FILE=ftn09, FORM='FORMATTED')
+
+c             write(9,'(a1)') ' '
+c                    write(9,'(10i5)')
+c     &                  (ilev,ilev=5,nlev,5)
+c             write(9,'(a1)') ' '
+             
+c             do ibox=1,ncol
+c               write(9,'(40(a1),1x,40(a1))')
+c     &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) 
+c     &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 
+c             end do
+c            close(9)
+c
+cIM
+c             if (ncolprint.ne.0) then
+c               write(6,'(a1)') ' '
+c                    write(6,'(a2,1X,5(a7,1X),a50)') 
+c     &                  'ilev',
+c     &                  'pfull','at',
+c     &                  'cc*100','dem_s','dtau_s',
+c     &                  '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
+c               write (6,'(a)') 'skt(j):'
+c               write (6,'(8f7.2)') skt(j)
+                                      
+c               write (6,'(8I7)') (ibox,ibox=1,ncolprint)
+	      
+c               write (6,'(a)') 'tau:'
+c               write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+    
+c               write (6,'(a)') 'tb:'
+c               write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+    
+c               write (6,'(a)') 'ptop:'
+c               write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
+c             endif 
+    
+c        enddo
+       
+c      end if 
+
+      return
+      end 
Index: LMDZ4/tags/LF_20080728/libf/phylmd/lnblnk1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/lnblnk1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/lnblnk1.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      INTEGER FUNCTION lnblnk1 (letter)
+
+C--------------------------------------------------------
+C Fonction qui determine la longeur d'un string sans les
+C blancs qui suivent. Le critere pour determiner la fin du
+C string est, trois blancs de suite
+C---------------------------------------------------------
+C     ARGUMENTS
+C     +++++++++
+C     letter: CHARACTER*xxx (xxx < imax)
+C             le string dont on determine la longuer
+C     lnblnk1: INTEGER
+C             le nombre de characteres
+C
+C     PARAMETER
+C     +++++++++
+C     imax : INTEGER
+C            le nombre maximale de character que peut contenir le string
+C            a traiter
+
+      IMPLICIT NONE
+      INTEGER i,imax
+      PARAMETER (imax = 256)
+c     CHARACTER*256 letter
+      CHARACTER*4 letter
+
+      i=0
+
+10    i=i+1
+c     IF (letter(i:i+1) . EQ . ' ') THEN
+      IF (letter(i:i) . EQ . ' ') THEN
+c      print*,'i=',i,'letter(i:i+1)=',letter(i:i+1)
+c      print*,'i=',i
+       GOTO 20
+      ELSE
+       GOTO 10
+      ENDIF
+
+20    lnblnk1=i-1
+c     PRINT*,'lnblnk1=',lnblnk1
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/minmaxqfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/minmaxqfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/minmaxqfi.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      CHARACTER*(*) comment
+      real qmin,qmax
+      real zq(klon,klev)
+
+      INTEGER jadrs(klon), jbad, k, i
+
+      DO k = 1, klev
+         jbad = 0
+         DO i = 1, klon
+         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+         IF (jbad.GT.0) THEN
+         PRINT*, comment
+         DO i = 1, jbad
+            PRINT*, "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
+         ENDDO
+         ENDIF
+      ENDDO
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_grid_phy_lmdz.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_grid_phy_lmdz.F90	(revision 984)
@@ -0,0 +1,447 @@
+!
+!$Header$
+!
+MODULE mod_grid_phy_lmdz
+  INTEGER :: nbp_lon  ! == iim
+  INTEGER :: nbp_lat  ! == jjmp1
+  INTEGER :: nbp_lev  ! == llm
+  INTEGER :: 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
+
+END MODULE mod_grid_phy_lmdz
+
+
+  
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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   
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_mpi_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_mpi_data.F90	(revision 984)
@@ -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_ok_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_PARA
+    is_ok_mpi=.TRUE.
+#else
+    is_ok_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_ok_mpi) THEN    
+#ifdef CPP_PARA
+      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
+  
+  
+    PRINT *, 'ii_begin =', ii_begin
+    PRINT *, 'ii_end =', ii_end
+    PRINT *, 'jj_begin =',jj_begin
+    PRINT *, 'jj_end =', jj_end
+    PRINT *, 'jj_nb =', jj_nb
+    PRINT *, 'ij_begin =', ij_begin
+    PRINT *, 'ij_end =', ij_end
+    PRINT *, 'ij_nb =', ij_nb
+    PRINT *, 'klon_mpi_begin =', klon_mpi_begin
+    PRINT *, 'klon_mpi_end =', klon_mpi_end
+    PRINT *, 'klon_mpi =', klon_mpi
+    PRINT *, 'jj_para_nb =', jj_para_nb
+    PRINT *, 'jj_para_begin =', jj_para_begin
+    PRINT *, 'jj_para_end =', jj_para_end
+    PRINT *, 'ii_para_begin =', ii_para_begin
+    PRINT *, 'ii_para_end =', ii_para_end
+    PRINT *, 'ij_para_nb =', ij_para_nb
+    PRINT *, 'ij_para_begin =', ij_para_begin
+    PRINT *, 'ij_para_end =', ij_para_end
+    PRINT *, 'klon_mpi_para_nb =', klon_mpi_para_nb
+    PRINT *, 'klon_mpi_para_begin =', klon_mpi_para_begin
+    PRINT *, 'klon_mpi_para_end  =', klon_mpi_para_end 
+    PRINT *, 'mpi_rank =', mpi_rank
+    PRINT *, 'mpi_size =', mpi_size
+    PRINT *, 'mpi_root =', mpi_root
+    PRINT *, 'is_mpi_root =', is_mpi_root
+    PRINT *, 'is_north_pole =', is_north_pole
+    PRINT *, 'is_south_pole =', is_south_pole
+    PRINT *, 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_mpi_transfert.F90	(revision 984)
@@ -0,0 +1,2444 @@
+!
+!$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
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+
+    CALL bcast_mpi_cgen(Var1,len(Var1))
+  END SUBROUTINE bcast_mpi_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_mpi_i(var1)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var1
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var1,1)
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,1)
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,1)
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    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
+
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+     IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,1)
+     ELSE
+      CALL scatter_mpi_igen(dummy,Varout,1)
+    ENDIF
+    
+  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
+    
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2))
+    ENDIF
+    
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,1)
+    ENDIF
+    
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,1)      
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))      
+    ENDIF
+  
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+	INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+  
+ 
+  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
+
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+ 
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+ 
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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 :: dummy
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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 :: dummy
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+
+
+                            
+END MODULE mod_phys_lmdz_mpi_transfert
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+    
+#ifdef CPP_PARA
+    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,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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
+    
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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
+    
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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_PARA
+    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_ok_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_PARA 
+    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_PARA
+    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_ok_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_PARA 
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    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_ok_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+#ifdef CPP_PARA
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    INCLUDE 'mpif.h'
+#endif
+   
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+   
+    IF (.not.is_ok_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+#ifdef CPP_PARA
+    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_PARA
+    INCLUDE 'mpif.h'
+#endif
+    
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+ 
+    IF (.not.is_ok_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+#ifdef CPP_PARA
+    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   
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_omp_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_omp_data.F90	(revision 984)
@@ -0,0 +1,104 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_data
+
+  INTEGER,SAVE :: omp_size
+  INTEGER,SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_ok_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
+
+#ifdef _OPENMP    
+    INTEGER :: OMP_GET_NUM_THREADS
+    EXTERNAL OMP_GET_NUM_THREADS
+    INTEGER :: OMP_GET_THREAD_NUM
+    EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef _OPENMP
+!$OMP MASTER
+        is_ok_omp=.TRUE.
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+    is_ok_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
+     PRINT *,'ANORMAL : OMP_MASTER /= 0'
+     STOP
+   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
+
+!$OMP CRITICAL  
+  PRINT *,'--------> TASK ',omp_rank
+  PRINT *,'omp_size =',omp_size
+  PRINT *,'omp_rank =',omp_rank
+  PRINT *,'is_omp_root =',is_omp_root
+  PRINT *,'klon_omp_para_nb =',klon_omp_para_nb
+  PRINT *,'klon_omp_para_begin =',klon_omp_para_begin
+  PRINT *,'klon_omp_para_end =',klon_omp_para_end    
+  PRINT *,'klon_omp =',klon_omp
+  PRINT *,'klon_omp_begin =',klon_omp_begin
+  PRINT *,'klon_omp_end =',klon_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE Print_module_data
+END MODULE mod_phys_lmdz_omp_data
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_omp_transfert.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_omp_transfert.F90	(revision 984)
@@ -0,0 +1,1105 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  INTEGER,PARAMETER :: omp_buffer_size = 1024*1024*16
+  INTEGER,SAVE,DIMENSION(omp_buffer_size) :: omp_buffer
+  
+  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 
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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),omp_buffer)
+    
+  END SUBROUTINE bcast_omp_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_omp_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_igen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_i
+
+
+  SUBROUTINE bcast_omp_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i1
+
+
+  SUBROUTINE bcast_omp_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i2
+
+
+  SUBROUTINE bcast_omp_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i3
+
+
+  SUBROUTINE bcast_omp_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_rgen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_r
+
+
+  SUBROUTINE bcast_omp_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r1
+
+
+  SUBROUTINE bcast_omp_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r2
+
+
+  SUBROUTINE bcast_omp_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r3
+
+
+  SUBROUTINE bcast_omp_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r4
+
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_lgen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_l
+
+
+  SUBROUTINE bcast_omp_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l1
+
+
+  SUBROUTINE bcast_omp_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l2
+
+
+  SUBROUTINE bcast_omp_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l3
+
+
+  SUBROUTINE bcast_omp_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l4
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_igen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_i
+
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_i1
+  
+  
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_i2
+
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_i3
+
+
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_rgen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_r
+
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_r1
+  
+  
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_r2
+
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_r3
+  
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_lgen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_l
+
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_l1
+  
+  
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_l2
+
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_l3  
+  
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_igen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i2
+  
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i3
+
+
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_rgen(VarIn,dummy,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r3
+
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_lgen(VarIn,dummy,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l2
+  
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l3
+
+
+
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    CALL reduce_sum_omp_igen(VarIn,Varout,1,omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+   
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    CALL reduce_sum_omp_rgen(VarIn,Varout,1,omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+   
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  END SUBROUTINE reduce_sum_omp_r4
+
+
+
+END MODULE mod_phys_lmdz_omp_transfert
+
+
+
+
+
+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,DIMENSION(Nb),INTENT(INOUT) :: Var
+  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
+    
+  REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
+    
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_para.F90	(revision 984)
@@ -0,0 +1,106 @@
+!
+!$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
+  
+!$OMP THREADPRIVATE(klon_loc)
+  
+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
+    CALL Test_transfert
+!$OMP END PARALLEL    
+     IF (is_ok_mpi .OR. is_ok_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
+  
+    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)
+      PRINT *, "------> 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)
+      PRINT *, "------> 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)
+      PRINT *, "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+     
+   END SUBROUTINE Test_transfert
+  
+END MODULE mod_phys_lmdz_para
+    
Index: LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_transfert_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/mod_phys_lmdz_transfert_para.F90	(revision 984)
@@ -0,0 +1,1661 @@
+!
+!$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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(s1) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(s1,s2) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(s1,s2,s3) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3,s4)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3,s4
+      INTEGER,DIMENSION(s1,s2,s3,s4) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+   
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(s1) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(s1,s2) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(s1,s2,s3) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3,s4)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3,s4
+      REAL,DIMENSION(s1,s2,s3,s4) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+   
+  END SUBROUTINE reduce_sum_r4  
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/moy_undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/moy_undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/moy_undefSTD.F	(revision 984)
@@ -0,0 +1,83 @@
+!
+! $Header$
+!
+      SUBROUTINE moy_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $           tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Moyenne - a des frequences differentes - des valeurs bien definies
+c         (.NE.1.E+20) des variables interpolees a un niveau de
+c         pression.
+c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
+c    tous les pas de temps de la physique
+c
+c 2) les variables de type "NMC" (nout=3) sont calculees a partir
+c    des valeurs instantannees toutes les 6 heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c
+c variables Input
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime, ecrit_day, ecrit_mth, ecrit_hf2mth
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+c
+c variables Output
+      REAL tnondef(klon,klevSTD,nout)
+      REAL tsumSTD(klon,klevSTD,nout)
+c
+c calcul 1 fois par jour
+c
+      IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.0) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,1).NE.(ecrit_day/dtime)) THEN
+          tsumSTD(i,k,1)=tsumSTD(i,k,1)/
+     $    (ecrit_day/dtime-tnondef(i,k,1))
+         ELSE
+          tsumSTD(i,k,1)=1.E+20
+         ENDIF !tnondef
+        ENDDO !i
+       ENDDO !k
+      ENDIF !MOD(itap,ecrit_day).EQ.0
+c
+c calcul 1 fois par mois
+c
+      IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.0) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,2).NE.ecrit_mth/dtime) THEN
+          tsumSTD(i,k,2)=tsumSTD(i,k,2)/
+     $    (ecrit_mth/dtime-tnondef(i,k,2))
+         ELSE
+          tsumSTD(i,k,2)=1.E+20
+         ENDIF !tnondef
+c
+         IF(tnondef(i,k,3).NE.NINT(ecrit_hf2mth)) THEN
+          tsumSTD(i,k,3)=tsumSTD(i,k,3)/
+     $    (ecrit_hf2mth-tnondef(i,k,3))
+         ELSE
+          tsumSTD(i,k,3)=1.E+20
+         ENDIF !tnondef
+c
+        ENDDO !i
+       ENDDO !k
+      ENDIF !MOD
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phylmd/moyglo_aire.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/moyglo_aire.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/moyglo_aire.F	(revision 984)
@@ -0,0 +1,161 @@
+!
+! $Header$
+!
+      SUBROUTINE moyglo_pondaire(nhori, champ, aire, 
+     .            ok_msk, msk, moyglo)
+c
+       USE dimphy
+       IMPLICIT none
+c
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
+c
+c moyenne = Somme_(champ* aire)/Somme_aire
+c
+c ==================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+       INTEGER i, nhori
+       REAL champ(klon), aire(klon), msk(klon)
+       LOGICAL ok_msk 
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaire nhori',nhori
+c
+       airetot=0.
+       moyglo=0.
+c
+       IF(ok_msk) THEN
+        DO i=1, nhori
+c        IF(msk(i).EQ.1.) THEN 
+         IF(msk(i).GT.0.) THEN 
+c
+c aire totale
+          airetot=airetot+aire(i)*msk(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i)*msk(i) 
+         ENDIF
+        ENDDO
+c
+       ELSE !ok_msk
+        DO i=1, nhori
+c
+c aire totale
+          airetot=airetot+aire(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i) 
+        ENDDO 
+c
+       ENDIF
+c 
+c moyenne ponderee par l'aire
+       moyglo=moyglo/airetot
+c
+       RETURN 
+       END
+c
+       SUBROUTINE moyglo_pondaima(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
+c totale avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_aire
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c aire totale
+       airetot=0.
+       DO i=1, nhori
+        airetot=airetot+aire(i)
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/airetot
+c
+      RETURN
+      END
+c
+       SUBROUTINE moyglo_pondmass(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par la
+c masse totale d'air, avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL massetot
+c
+c      PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c masse totale
+       massetot=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        massetot=massetot+
+     .  (pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/massetot
+c
+      RETURN
+      END
+c
Index: LMDZ4/tags/LF_20080728/libf/phylmd/newmicro.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/newmicro.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/newmicro.F	(revision 984)
@@ -0,0 +1,364 @@
+!
+! $Header$
+!
+      SUBROUTINE newmicro (paprs, pplay,ok_newmicro,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     s                  xflwp, xfiwp, xflwc, xfiwc,
+     e                  ok_aie, 
+     e                  sulfate, sulfate_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c 
+c ok_aie--input-L-apply aerosol indirect effect or not
+c sulfate-input-R-sulfate aerosol mass concentration [um/m^3]
+c sulfate_pi-input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell           
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "nuage.h"
+cIM cf. CR: include pour NOVLP et ZEPSEC
+#include "radepsi.h"
+#include "radopt.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+cIM: 091003   REAL zflwp, zradef, zfice, zmsac
+      REAL zflwp(klon), zradef, zfice, zmsac
+cIM: 091003 rajout
+      REAL xflwp(klon), xfiwp(klon)
+      REAL xflwc(klon,klev), xfiwc(klon,klev)
+c
+      REAL radius, rad_chaud
+cc      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+ccc      PARAMETER (nexpo=1)
+
+c -- sb:
+      logical ok_newmicro
+c     parameter (ok_newmicro=.FALSE.)
+cIM: 091003   real rel, tc, rei, zfiwp
+      real rel, tc, rei, zfiwp(klon)
+      real k_liq, k_ice0, k_ice, DF
+      parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g
+      parameter (DF=1.66) ! diffusivity factor
+c sb --
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      LOGICAL ok_a1lwpdep       ! a1 LWP dependent?
+      
+      REAL sulfate(klon, klev)  ! sulfate aerosol mass concentration [ug m-3]
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL sulfate_pi(klon, klev)  ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value)
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)       ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end    
+cIM cf. CR:parametres supplementaires
+      REAL zclear(klon)
+      REAL zcloud(klon) 
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+cIM inversion des DO
+      DO i = 1, klon
+       xflwp(i)=0.
+       xfiwp(i)=0.
+cccccccccccc!CDIR NOVECTOR
+      DO k = 1, klev
+c
+       xflwc(i,k)=0.
+       xfiwc(i,k)=0.
+c
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp(i) = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp(i) / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp(i))
+
+         if (ok_newmicro) then
+
+c -- liquid/ice cloud water paths:
+
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+
+         zflwp(i) = 1000.*(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         zfiwp(i) = 1000.*zfice*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+         xflwp(i) = xflwp(i)+ (1.-zfice)*pqlwp(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         xfiwp(i) = xfiwp(i)+ zfice*pqlwp(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+cIM Total Liquid/Ice water content
+         xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)
+         xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)
+cIM In-Cloud Liquid/Ice water content
+c        xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+c        xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)/pclc(i,k)
+
+c -- effective cloud droplet radius (microns):
+
+c for liquid water clouds: 
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            !
+            !
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+c           rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            rad_chaud = MAX(rad_chaud*1.e6, 5.) 
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc_pi(i,k)) )**(1./3.)
+            radius = MAX(radius*1.e6, 5.) 
+            
+            tc = t(i,k)-273.15
+            rei = 0.71*tc + 61.29 
+            if (tc.le.-81.4) rei = 3.5 
+            if (zflwp(i).eq.0.) radius = 1. 
+            if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. 
+            cldtaupi(i,k) = 3.0/2.0 * zflwp(i) / radius
+     .             + zfiwp(i) * (3.448e-03  + 2.431/rei)
+         ENDIF                  ! ok_aie
+         ! For output diagnostics
+         !
+         ! Cloud droplet effective radius [um]
+         !
+         ! we multiply here with f * xl (fraction of liquid water
+         ! clouds in the grid cell) to avoid problems in the
+         ! averaging of the output.
+         ! In the output of IOIPSL, derive the real cloud droplet 
+         ! effective radius as re/fl
+         !
+         fl(i,k) = pclc(i,k)*(1.-zfice)            
+         re(i,k) = rad_chaud*fl(i,k)
+            
+c-jq end         
+         
+         rel = rad_chaud
+c for ice clouds: as a function of the ambiant temperature
+c [formula used by Iacobellis and Somerville (2000), with an 
+c asymptotical value of 3.5 microns at T<-81.4 C added to be 
+c consistent with observations of Heymsfield et al. 1986]:
+         tc = t(i,k)-273.15
+         rei = 0.71*tc + 61.29 
+         if (tc.le.-81.4) rei = 3.5 
+
+c -- cloud optical thickness :
+
+c [for liquid clouds, traditional formula, 
+c  for ice clouds, Ebert & Curry (1992)] 
+
+         if (zflwp(i).eq.0.) rel = 1. 
+         if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. 
+         pcltau(i,k) = 3.0/2.0 * ( zflwp(i)/rel )
+     .             + zfiwp(i) * (3.448e-03  + 2.431/rei)
+
+c -- cloud infrared emissivity:
+
+c [the broadband infrared absorption coefficient is parameterized
+c  as a function of the effective cld droplet radius]
+
+c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+         k_ice = k_ice0 + 1.0/rei
+
+         pclemi(i,k) = 1.0
+     .      - EXP( - coef_chau*zflwp(i) - DF*k_ice*zfiwp(i) )
+
+         endif ! ok_newmicro
+
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (lo) cldtaupi(i,k) = 0.0
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+cIM cf. CR:test: calcul prenant ou non en compte le recouvrement
+cinitialisations
+      DO i=1,klon
+         zclear(i)=1.
+         zcloud(i)=0.
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+cIM cf CR DO k=1,klev
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+cIM cf. CR
+            IF (NOVLP.EQ.1) THEN
+               zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               pct(i)=1.-zclear(i) 
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+                  pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then
+                  pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then 
+                  pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               endif
+               zcloud(i)=pclc(i,k)
+            ELSE IF (NOVLP.EQ.2) THEN
+               zcloud(i)=MAX(pclc(i,k),zcloud(i))
+               pct(i)=zcloud(i)
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+                  pch(i) = MIN(pclc(i,k),pch(i))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then
+                  pcm(i) = MIN(pclc(i,k),pcm(i))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then
+                  pcl(i) = MIN(pclc(i,k),pcl(i))
+               endif
+            ELSE IF (NOVLP.EQ.3) THEN
+               zclear(i)=zclear(i)*(1.-pclc(i,k))
+               pct(i)=1-zclear(i)
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+               pch(i) = pch(i)*(1.0-pclc(i,k))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then 
+               pcm(i) = pcm(i)*(1.0-pclc(i,k))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then
+               pcl(i) = pcl(i)*(1.0-pclc(i,k))
+               endif
+            ENDIF
+         ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+cIM cf. CR          pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/nflxtr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/nflxtr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/nflxtr.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pplay,paprs,x,dx) 
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant 
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--flux convectifs mais en variables locales
+      REAL zmfu(klon,klev+1) 
+      REAL zmfd(klon,klev+1) 
+      REAL zen_u(klon,klev) 
+      REAL zde_u(klon,klev)
+      REAL zen_d(klon,klev) 
+      REAL zde_d(klon,klev)
+      real zmfe
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+
+c =========================================
+c
+c
+c   Extension des flux UP et DN sur klev+1 niveaux
+c =========================================
+      do k=1,klev
+         do i=1,klon
+            zmfu(i,k)=pmfu(i,k)
+            zmfd(i,k)=pmfd(i,k)
+         enddo
+      enddo
+      do i=1,klon
+         zmfu(i,klev+1)=0.
+         zmfd(i,klev+1)=0.
+      enddo
+
+c--modif pour diagnostiquer les detrainements
+c =========================================
+c   on privilegie l'ajustement de l'entrainement dans l'ascendance.
+
+      do k=1, klev
+         do i=1, klon
+            zen_d(i,k)=pen_d(i,k)
+            zde_u(i,k)=pde_u(i,k)
+            zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
+            zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
+         enddo 
+      enddo 
+c
+c--calcul des flux dans le panache montant
+c =========================================
+c
+c Dans la premiere couche, on prend q comme valeur de qu
+c
+      do i=1, klon
+         zmfux(i,1)=0.0 
+      enddo
+c
+c Autres couches
+      do k=1,klev
+         do i=1, klon
+            if ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
+               xu(i,k)=x(i,k)
+            else
+               xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))
+     s               /(zmfu(i,k+1)+zde_u(i,k))
+            endif
+            zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
+         enddo
+      enddo
+c
+c--calcul des flux dans le panache descendant
+c =========================================
+c   
+      do i=1, klon
+         zmfdx(i,klev+1)=0.0 
+      enddo
+c
+      do k=klev,1,-1
+         do i=1, klon
+            if ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
+               xd(i,k)=x(i,k)
+            else
+               xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k)) /
+     .               (zmfd(i,k)-zde_d(i,k))
+            endif
+            zmfdx(i,k)=zmfd(i,k)*xd(i,k)
+         enddo
+      enddo
+c
+c--introduction du flux de retour dans l'environnement
+c =========================================
+c
+      do k=2, klev
+         do i=1, klon
+            zmfe=-zmfu(i,k)-zmfd(i,k)
+            if (zmfe.le.0.) then
+               zmfex(i,k)= zmfe*x(i,k)
+            else
+               zmfex(i,k)= zmfe*x(i,k-1)
+            endif
+         enddo
+      enddo
+
+      do i=1, klon
+         zmfex(i,1)=0.
+         zmfex(i,klev+1)=0.
+      enddo
+c
+c--calcul final des tendances
+c
+      do k=1, klev
+         do i=1, klon
+            dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*
+     .                      ( zmfux(i,k) - zmfux(i,k+1) +
+     .                        zmfdx(i,k) - zmfdx(i,k+1) +
+     .                        zmfex(i,k) - zmfex(i,k+1) )
+         enddo
+      enddo
+c
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/nonlocal.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/nonlocal.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/nonlocal.F	(revision 984)
@@ -0,0 +1,415 @@
+!
+! $Header$
+!
+C======================================================================
+      SUBROUTINE nonlocal(knon, paprs, pplay,
+     .                    tsol,beta,u,v,t,q,
+     .                    cd_h, cd_m, pcfh, pcfm, cgh, cgq)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+#include "YOMCST.h"
+#include "iniprint.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL tsol(klon) ! temperature du sol (K)
+      REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+      REAL vk
+      PARAMETER (vk=0.40)
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)
+      REAL fakn
+      PARAMETER (fakn=7.2)
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)
+      REAL sffrac
+      PARAMETER (sffrac=0.1)
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL z(klon,klev)
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL ustar(klon)
+      REAL rino(klon,klev)  ! bulk Richardon no. from level to ref lev
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      REAL pblh(klon)
+      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)
+      REAL ztvd, ztvu, zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5, zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation
+c
+      isommet=klev
+
+      DO i = 1, klon
+         pcfh(i,1) = cd_h(i)
+         pcfm(i,1) = cd_m(i)
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         pcfh(i,k) = zkmin
+         pcfm(i,k) = zkmin
+         cgs(i,k) = 0.0
+         cgh(i,k) = 0.0
+         cgq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+      ENDDO
+      ENDDO
+c
+      DO i = 1, knon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+           zxqs=MIN(0.5,zxqs)
+           zcor=1./(1.-retv*zxqs)
+           zxqs=zxqs*zcor
+         ELSE
+           IF (tsol(i).LT.t_coup) THEN
+              zxqs = qsats(tsol(i)) / paprs(i,1)
+           ELSE
+              zxqs = qsatl(tsol(i)) / paprs(i,1)
+           ENDIF
+         ENDIF
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .        *(1.+RETV*q(i,1))*zx_alf1
+     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+     .        *(1.+RETV*q(i,2))*zx_alf2
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+      ENDDO
+c
+      DO i = 1, knon
+         rino(i,1) = 0.0
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+      ENDDO
+
+C
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C
+      fac = 100.0
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+        wm(i)= ustar(i)*phiminv(i)
+        therm(i) = heatv(i)*fak/wm(i)
+        rino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+C Improve pblh estimate for unstable conditions using the
+C convective temperature excess:
+C
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Points for which pblh exceeds number of pbl layers allowed;
+C set to maximum
+C
+      DO i = 1, knon
+        IF (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+      ENDDO
+C
+C pblh is now available; do preparation for diffusivity calculation:
+C
+      DO i = 1, knon
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C
+        IF (unstbl(i)) THEN
+          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+C
+C For all unstable layers, set diffusivities
+C
+        DO i = 1, knon
+        IF (unslev(i)) THEN
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pblk(i)/pr(i)
+        ENDIF
+        ENDDO
+ 1000 continue           ! end of level loop
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/nuage.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/nuage.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/nuage.F	(revision 984)
@@ -0,0 +1,409 @@
+!
+! $Header$
+!
+      SUBROUTINE nuage (paprs, pplay,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     e                  ok_aie,
+     e                  sulfate, sulfate_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c ok_aie--input-L-apply aerosol indirect effect or not
+c sulfate-input-R-sulfate aerosol mass concentration [um/m^3]
+c sulfate_pi-input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell      
+c 
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+c
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+      
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      
+      REAL sulfate(klon, klev)  ! sulfate aerosol mass concentration [ug m-3]
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL sulfate_pi(klon, klev)  ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value)
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)  ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end      
+      
+ccc      PARAMETER (nexpo=1)
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+            
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+            rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            
+            ! For output diagnostics
+            !
+            ! Cloud droplet effective radius [um]
+            !
+            ! we multiply here with f * xl (fraction of liquid water
+            ! clouds in the grid cell) to avoid problems in the
+            ! averaging of the output.
+            ! In the output of IOIPSL, derive the real cloud droplet 
+            ! effective radius as re/fl
+            !
+            fl(i,k) = pclc(i,k)*(1.-zfice)            
+            re(i,k) = rad_chaud*fl(i,k)
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k)))  
+     .                / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.), 
+     .               3.) * (1.-zfice) + rad_froid * zfice           
+            cldtaupi(i,k) = 3.0/2.0 * zflwp / radius
+     .           
+         ENDIF                  ! ok_aie
+         
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))
+     .      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .       pplay(i,k).LE.cetamb*paprs(i,1)) 
+     .      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))
+     .      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,
+     .                   diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+c Laurent Li (LMD/CNRS), le 12 octobre 1998
+c                        (adaptation du code ECMWF)
+c
+c Dans certains cas, le schema pronostique des nuages n'est
+c pas suffisament performant. On a donc besoin de diagnostiquer
+c ces nuages. Je dois avouer que c'est une frustration.
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+c
+c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon ! pour traiter les enclumes
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.
+     .    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))
+     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
+     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+c
+c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))
+     .          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.
+     .       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)
+     .   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/nuage.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/nuage.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/nuage.h	(revision 984)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      REAL rad_froid, rad_chau1, rad_chau2
+
+      common /nuagecom/ rad_froid,rad_chau1, rad_chau2
+!$OMP THREADPRIVATE(/nuagecom/)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/o3cm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/o3cm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/o3cm.F	(revision 984)
@@ -0,0 +1,61 @@
+!
+! $Header$
+!
+      SUBROUTINE o3cm (amb, bmb, sortie, ntab)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ce programme calcule le contenu en ozone "sortie"
+c        (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb)
+c        "ntab" est le nombre d'intervalles pour l'integration, sa
+c        valeur depend bien sur de l'epaisseur de la couche et de
+c        la precision qu'on souhaite a obtenir
+c======================================================================
+      REAL amb, bmb, sortie
+      INTEGER ntab
+c======================================================================
+      INTEGER n
+      REAL xtab(500), xa, xb, ya, yb, xincr
+c======================================================================
+      external mbtozm
+c======================================================================
+c la fonction en ligne w(x) donne le profil de l'ozone en fonction
+c de l'altitude (unite: cm.atm / km)
+c (Green 1964, Appl. Opt. 3: 203-208)
+      REAL wp, xp, h, x, w, con
+      PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0)
+      w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2
+c======================================================================
+      IF (ntab .GT. 499) STOP 'BIG ntab'
+      xincr = (bmb-amb) / FLOAT(ntab)
+      xtab(1) = amb
+      DO n = 2, ntab
+         xtab(n) = xtab(n-1) + xincr
+      ENDDO
+      xtab(ntab+1) = bmb
+      sortie = 0.0
+      DO n = 1, ntab
+         CALL mbtozm(xtab(n), xa)
+         CALL mbtozm(xtab(n+1), xb)
+         xa = xa / 1000.
+         xb = xb / 1000.
+         ya = w(xa)
+         yb = w(xb)
+         sortie = sortie + (ya+yb)/2.0 * ABS(xb-xa)
+      ENDDO
+      RETURN
+      END
+      SUBROUTINE mbtozm(rmb,zm)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Objet: transformer une hauteur de mb (rmb) en metre (zm)
+c======================================================================
+      REAL rmb, zm
+c======================================================================
+      REAL gama, tzero, pzero, g, r
+      PARAMETER (gama=6.5e-3, tzero=288., pzero=1013.25)
+      PARAMETER (g=9.81, r=287.0)
+      zm = tzero/gama * ( 1.-(rmb/pzero)**(r*gama/g) )
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/oasis.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/oasis.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/oasis.F90	(revision 984)
@@ -0,0 +1,396 @@
+!
+! $Header$
+!
+MODULE oasis
+!
+! This module contains subroutines for initialization, sending and receiving 
+! towards the coupler OASIS3. It also contains some parameters for the coupling.
+!
+! This module should always be compiled. With the coupler OASIS3 available the cpp key
+! CPP_COUPLE should be set and the entier of this file will then be compiled. 
+! In a forced mode CPP_COUPLE should not be defined and the compilation ends before 
+! the CONTAINS, without compiling the subroutines.
+!
+  USE dimphy 
+  USE mod_phys_lmdz_para
+  USE write_field_phy
+
+#ifdef CPP_COUPLE
+  USE mod_prism_proto
+  USE mod_prism_def_partition_proto
+  USE mod_prism_get_proto
+  USE mod_prism_put_proto
+#endif
+  
+  IMPLICIT NONE
+    
+! Maximum number of fields exchanged between ocean and atmosphere
+  INTEGER, PARAMETER  :: jpmaxfld=40
+! Number of fields exchanged from atmosphere to ocean via flx.F
+  INTEGER, PARAMETER  :: jpflda2o1=13
+! Number of fields exchanged from atmosphere to ocean via tau.F
+  INTEGER, PARAMETER  :: jpflda2o2=6
+! Number of fields exchanged from ocean to atmosphere
+  INTEGER, PARAMETER  :: jpfldo2a=4
+
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_read
+  !$OMP THREADPRIVATE(cl_read)
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_writ
+  !$OMP THREADPRIVATE(cl_writ)
+
+  INTEGER, DIMENSION(jpfldo2a), SAVE, PRIVATE            :: in_var_id
+  !$OMP THREADPRIVATE(in_var_id)
+  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
+  !$OMP THREADPRIVATE(out_var_id)
+
+
+#ifdef CPP_COUPLE
+
+CONTAINS
+
+  SUBROUTINE inicma
+!************************************************************************************
+!**** *INICMA*  - Initialize coupled mode communication for atmosphere
+!                 and exchange some initial information with Oasis
+!
+!     Rewrite to take the PRISM/psmile library into account
+!     LF 09/2003
+!
+    INCLUDE "dimensions.h"
+
+! Local variables
+!************************************************************************************
+    INTEGER                            :: comp_id
+    INTEGER                            :: ierror, il_commlocal
+    INTEGER                            :: il_part_id
+    INTEGER, DIMENSION(3)              :: ig_paral
+    INTEGER, DIMENSION(2)              :: il_var_nodims
+    INTEGER, DIMENSION(4)              :: il_var_actual_shape
+    INTEGER                            :: il_var_type
+    INTEGER                            :: nuout = 6
+    INTEGER                            :: jf
+    CHARACTER (len = 6)                :: clmodnam
+    CHARACTER (len = 20)               :: modname = 'inicma'
+    CHARACTER (len = 80)               :: abort_message 
+
+!*    1. Initializations
+!        ---------------
+!************************************************************************************
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' ROUTINE INICMA'
+    WRITE(nuout,*) ' **************'
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+
+!
+! Define the model name
+!
+    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+!
+!************************************************************************************
+! Here we go: psmile initialisation
+!************************************************************************************
+    IF (is_sequential) THEN
+       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
+       
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_init_comp '
+          CALL abort_gcm(modname,abort_message,1)
+       ELSE
+          WRITE(nuout,*) 'inicma : init psmile ok '
+       ENDIF
+    ENDIF
+
+    CALL prism_get_localcomm_proto (il_commlocal, ierror)
+!************************************************************************************
+! Domain decomposition
+!************************************************************************************
+    ig_paral(1) = 1                            ! apple partition for //
+    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
+    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
+
+    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
+    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
+    
+    ierror=PRISM_Ok
+    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
+
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme dans prism_def_partition '
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
+    ENDIF
+
+!************************************************************************************
+! Field Declarations
+!************************************************************************************
+!     Define symbolic name for fields exchanged from atmos to coupler,
+!         must be the same as (1) of the field  definition in namcouple:
+    cl_writ(1)='COTAUXXU'
+    cl_writ(2)='COTAUYYU'
+    cl_writ(3)='COTAUZZU'
+    cl_writ(4)='COTAUXXV'
+    cl_writ(5)='COTAUYYV'
+    cl_writ(6)='COTAUZZV'
+    cl_writ(7)='COWINDSP'
+    cl_writ(8)='COSHFICE'
+    cl_writ(9)='COSHFOCE'
+    cl_writ(10)='CONSFICE'
+    cl_writ(11)='CONSFOCE'
+    cl_writ(12)='CODFLXDT'
+    cl_writ(13)='COTFSICE'
+    cl_writ(14)='COTFSOCE'
+    cl_writ(15)='COTOLPSU'
+    cl_writ(16)='COTOSPSU'
+    cl_writ(17)='CORUNCOA'
+    cl_writ(18)='CORIVFLU'
+    cl_writ(19)='COCALVIN'
+!
+!     Define symbolic name for fields exchanged from coupler to atmosphere,
+!         must be the same as (2) of the field  definition in namcouple:
+!
+    cl_read(1)='SISUTESW'
+    cl_read(2)='SIICECOV'
+    cl_read(3)='SIICEALW'
+    cl_read(4)='SIICTEMW'
+    
+    il_var_nodims(1) = 2
+    il_var_nodims(2) = 1
+
+    il_var_actual_shape(1) = 1
+    il_var_actual_shape(2) = iim
+    il_var_actual_shape(3) = 1
+    il_var_actual_shape(4) = jjm+1
+   
+    il_var_type = PRISM_Real
+
+!************************************************************************************
+! Oceanic Fields
+!************************************************************************************
+    DO jf=1, jpfldo2a
+       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
+            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! Atmospheric Fields
+!************************************************************************************
+    DO jf=1, jpflda2o1+jpflda2o2
+       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
+            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! End definition
+!************************************************************************************
+    CALL prism_enddef_proto(ierror)
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme init dans prism_ endef_proto'
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : endef psmile ok '
+    ENDIF
+    
+  END SUBROUTINE inicma
+
+!
+!************************************************************************************
+!
+
+  SUBROUTINE fromcpl(ktime, tab_get)
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
+! and Sea-Ice provided by the coupler. Adaptation to psmile library
+!======================================================================
+!
+    INCLUDE "dimensions.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                               ::  ktime
+
+! Output arguments
+!************************************************************************************
+    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
+
+! Local variables
+!************************************************************************************
+    INTEGER                       :: nuout  = 6             ! listing output unit
+    INTEGER                       :: ierror, i
+    INTEGER                       :: istart,iend
+    CHARACTER (len = 20)          :: modname = 'fromcpl'
+    CHARACTER (len = 80)          :: abort_message 
+    REAL, DIMENSION(iim*jj_nb)    :: field
+
+!************************************************************************************
+    WRITE (nuout,*) ' '
+    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
+    WRITE (nuout,*) ' '
+    CALL flush (nuout)
+    
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    DO i = 1, jpfldo2a
+       field(:) = -99999.
+       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
+       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
+            ierror.NE.PRISM_FromRest &
+            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
+            .AND. ierror.NE.PRISM_FromRestOut) THEN
+          WRITE (nuout,*)  cl_read(i), ktime   
+          abort_message=' Probleme dans prism_get_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+    
+    
+  END SUBROUTINE fromcpl
+
+!
+!************************************************************************************
+! 
+
+  SUBROUTINE intocpl(ktime, last, tab_put) 
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
+! atmospheric coupling fields to the coupler with the psmile library.
+! IF last time step, writes output fields to binary files.
+! ======================================================================
+!
+! 
+    INCLUDE "dimensions.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                                          :: ktime
+    LOGICAL, INTENT(IN)                                          :: last
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
+
+! Local variables
+!************************************************************************************
+    LOGICAL                     :: checkout=.FALSE.
+    INTEGER                     :: istart,iend
+    INTEGER                     :: wstart,wend
+    INTEGER, PARAMETER          :: nuout = 6 
+    INTEGER                     :: ierror, i
+    REAL, DIMENSION(iim*jj_nb)  :: field
+    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
+    CHARACTER (len = 80)        :: abort_message 
+
+!************************************************************************************
+
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
+    WRITE(nuout,*) 'last  ', last
+    WRITE(nuout,*)
+
+
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    IF (checkout) THEN   
+       wstart=istart
+       wend=iend
+       IF (is_north_pole) wstart=istart+iim-1
+       IF (is_south_pole) wend=iend-iim+1
+       
+       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
+       CALL writeField_phy("fsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
+       CALL writeField_phy("fsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
+       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
+       CALL writeField_phy("evice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
+       CALL writeField_phy("evwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
+       CALL writeField_phy("lpre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
+       CALL writeField_phy("spre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
+       CALL writeField_phy("dirunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
+       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
+       CALL writeField_phy("calving",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
+       CALL writeField_phy("windsp",field(wstart:wend),1)
+    ENDIF
+   
+!************************************************************************************
+! PRISM_PUT
+!************************************************************************************
+
+    DO i = 1, jpflda2o1+jpflda2o2
+       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
+       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
+            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
+            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
+          WRITE (nuout,*)  cl_writ(i), ktime   
+          abort_message=' Probleme dans prism_put_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+    END DO
+   
+!************************************************************************************
+! Finalize PSMILE for the case is_sequential, if parallel finalization is done 
+! from Finalize_parallel in dyn3dpar/parallel.F90
+!************************************************************************************
+
+    IF (last) THEN
+       IF (is_sequential) THEN 
+          CALL prism_terminate_proto(ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             abort_message=' Probleme dans prism_terminate_proto '
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    ENDIF
+    
+    
+  END SUBROUTINE intocpl
+
+#endif
+  
+END MODULE oasis
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ocean_cpl_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ocean_cpl_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ocean_cpl_mod.F90	(revision 984)
@@ -0,0 +1,371 @@
+!
+! $Header$
+!
+MODULE ocean_cpl_mod
+!
+! This module is used both for the sub-surface ocean and sea-ice for the case of a 
+! coupled model configuration, ocean=couple. 
+!
+
+  USE dimphy,           ONLY : klon
+  USE cpl_mod
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE climb_wind_mod,   ONLY : calcul_wind_flux
+
+  IMPLICIT NONE
+  PRIVATE
+
+  PUBLIC :: ocean_cpl_init, ocean_cpl_get_vars, ocean_cpl_noice, ocean_cpl_ice
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_o
+  !$OMP THREADPRIVATE(tmp_flux_o)
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_g)
+
+!****************************************************************************************
+!
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
+!
+! Allocate fields for this module and initailize the module mod_cpl
+!
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
+
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! Initialize module cpl_init
+    CALL cpl_init(dtime, rlon, rlat)
+    
+  END SUBROUTINE ocean_cpl_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_noice( &
+       swnet, lwnet, alb1, &
+       windsp, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, agesno, &
+       qsurf, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice. The subroutine first receives fields from coupler, then some calculations at 
+! surface is done and finally it sends some fields to the coupler.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+!    
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    INTEGER, DIMENSION(1) :: iloc
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: zx_sl
+    REAL, DIMENSION(klon) :: fder_new
+    REAL, DIMENSION(klon) :: tsurf_cpl
+    REAL, DIMENSION(klon) :: taux, tauy
+    LOGICAL               :: check=.FALSE.
+
+! End definitions
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
+
+!****************************************************************************************
+! Receive sea-surface temperature(tsurf_cpl) and new fraction of ocean surface(pctsrf_oce) 
+! from coupler
+!
+!****************************************************************************************
+    CALL cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf_in, &
+         tsurf_cpl, pctsrf_oce)
+
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    ! Calcultate the flux of u and v at surface
+    CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!****************************************************************************************
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+       !IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+       !       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_ocean_fields(itime, knon, knindex, &
+         swnet, lwnet, fluxlat, fluxsens, &
+         precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, taux, tauy, windsp)
+    
+
+  END SUBROUTINE ocean_cpl_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_ice( &
+       rlon, rlat, swnet, lwnet, alb1, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       lafin, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, &
+       alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. The subroutine first receives 
+! fields from coupler, then some calculations at surface is done and finally sends 
+! some fields to the coupler.
+!    
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                 :: i
+    INTEGER, DIMENSION(1)   :: iloc
+    LOGICAL                 :: check=.FALSE.
+    REAL, PARAMETER         :: t_grnd=271.35
+    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
+    REAL, DIMENSION(klon)   :: taux, tauy
+    REAL, DIMENSION(klon)   :: alb_cpl
+
+! End definitions
+!****************************************************************************************
+    
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! Receive ocean temperature(tsurf_cpl), albedo(alb_cpl) and new fraction of 
+! seaice(pctsrf_sic) from coupler
+!
+!****************************************************************************************
+
+    CALL cpl_receive_seaice_fields(knon, knindex, &
+         tsurf_cpl, alb_cpl, pctsrf_sic)
+
+    alb1_new(1:knon) = alb_cpl(1:knon)
+    alb2_new(1:knon) = alb_cpl(1:knon)    
+
+    
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    dif_grnd = 0.
+    beta = 1.0
+    
+
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    ! Calcultate the flux of u and v at surface
+    CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!  IM: faire dependre le coefficient de conduction de la glace de mer
+!      de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!      actuel correspond a 3m de glace de mer, cf. L.Li
+!
+!****************************************************************************************
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_sic(knindex(i)) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * &
+            dif_grnd(i) * RCPD/cal(i) 
+    ENDDO
+    
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder ****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf_in, lafin, rlon, rlat, &
+       swnet, lwnet, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, taux, tauy)
+ 
+
+  END SUBROUTINE ocean_cpl_ice
+!  
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_get_vars(flux_o, flux_g)
+
+! This subroutine returns variables private in this module to an external 
+! routine (physiq).
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Set the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_cpl_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_cpl_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ocean_forced_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ocean_forced_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ocean_forced_mod.F90	(revision 984)
@@ -0,0 +1,380 @@
+!
+! $Header$
+!
+MODULE ocean_forced_mod
+!
+! This module is used for both the sub-surfaces ocean and sea-ice for the case of a 
+! forced ocean,  "ocean=force".
+!
+  USE surface_data,     ONLY : calice, calsno, tau_gl
+  USE fonte_neige_mod,  ONLY : fonte_neige
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE dimphy
+
+  IMPLICIT NONE
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+
+CONTAINS
+!
+!****************************************************************************************
+! 
+  SUBROUTINE ocean_forced_init
+! Allocate fields needed for this module
+!    
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_forced_init'
+!****************************************************************************************
+
+    ALLOCATE(tmp_flux_o(1:klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(1:klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF    
+
+
+  END SUBROUTINE ocean_forced_init
+!
+!****************************************************************************************
+!****************************************************************************************
+! 
+  SUBROUTINE ocean_forced_final
+! Allocate fields needed for this module
+!    
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_forced_init'
+!****************************************************************************************
+
+    DEALLOCATE(tmp_flux_o)
+    DEALLOCATE(tmp_flux_g)
+
+
+  END SUBROUTINE ocean_forced_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_noice(itime, dtime, jour, knon, knindex, &
+       debut, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, &
+       temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, agesno, & 
+       qsurf, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice.
+! The routine reads data from climatologie file and does some calculations at the 
+! surface. 
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: debut
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno !? put to 0 in ocean
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER                     :: i
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_lim, zx_sl
+    LOGICAL                     :: check=.FALSE.
+    REAL, DIMENSION(klon,nbsrf) :: pctsrf_lim
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_forced_noice'
+
+!****************************************************************************************
+! 1)    
+! Read from climatologie file SST and fraction of sub-surfaces
+!
+!****************************************************************************************
+! Get from file tsurf_lim and pctsrf_lim
+    CALL interfoce_lim(itime, dtime, jour, & 
+         knon, knindex, &
+         debut, &
+         tsurf_lim, pctsrf_lim)
+    
+!****************************************************************************************
+! 2)
+! Flux calculation
+!
+!****************************************************************************************
+! Set some variables for calcul_fluxs
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+  
+! 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, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!****************************************************************************************
+! 3)
+! Calculate tmp_flux_o
+!
+!****************************************************************************************
+!IM: flux ocean-atmosphere utile pour le "slab" ocean
+! The flux are written to hist file
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+
+!IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+!       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_lim(knindex(i),is_oce) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+!****************************************************************************************
+! 4)
+! Return the new values for the ocean fraction
+!
+!****************************************************************************************
+
+    pctsrf_oce(:) = pctsrf_lim(:,is_oce)
+
+  END SUBROUTINE ocean_forced_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_ice(itime, dtime, jour, knon, knindex, &
+       debut, &
+       tsurf_in, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsol, agesno, tsoil, &
+       qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. 
+! The routine reads data from climatologie file and does flux calculations at the 
+! surface.
+!    
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    LOGICAL, INTENT(IN)                  :: debut
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_sic
+
+
+! Local variables
+!****************************************************************************************
+    LOGICAL                     :: check=.FALSE.
+    INTEGER                     :: i
+    REAL                        :: zfra
+    REAL, PARAMETER             :: t_grnd=271.35
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_tmp
+    REAL, DIMENSION(klon)       :: soilcap, soilflux
+    REAL, DIMENSION(klon,nbsrf) :: pctsrf_lim
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! 1)    
+! Read from climatologie file SST and fraction of sub-surfaces
+!
+!****************************************************************************************
+    CALL interfoce_lim(itime, dtime, jour, & 
+         knon, knindex, &
+         debut, &
+         tsurf_tmp, pctsrf_lim)
+  
+    DO i = 1, knon
+       tsurf_tmp(i) = tsurf_in(i)
+       IF (pctsrf_lim(knindex(i),is_sic) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_tmp(i) = RTT - 1.8
+          IF (soil_model) tsoil(i,:) = RTT -1.8
+       ENDIF
+    ENDDO
+
+!****************************************************************************************
+! 2) 
+! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, 
+!                    dflux_s, dflux_l and qsurf
+!****************************************************************************************
+
+! calculate the parameters cal, beta, capsol and dif_grnd
+
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+    IF (soil_model) THEN 
+! update tsoil and calculate soilcap and soilflux
+       CALL soil(dtime, is_sic, knon,snow, tsurf_tmp, tsoil,soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+       dif_grnd = 1.0 / tau_gl
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+
+    beta = 1.0
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_tmp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!****************************************************************************************
+! 3)
+! Calculations due to snow and runoff
+!
+!****************************************************************************************
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_tmp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+    
+! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno)
+! 
+    CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:))  
+
+    WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0.
+
+    alb1_new(:) = 0.0
+    DO i=1, knon
+       zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0)))
+       alb1_new(i) = alb_neig(i) * zfra +  0.6 * (1.0-zfra)
+    ENDDO
+
+    alb2_new(:) = alb1_new(:)
+
+!****************************************************************************************
+! 4)
+! Calculate tmp_flux_g
+!
+!****************************************************************************************
+!
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+!IM: faire dependre le coefficient de conduction de la glace de mer
+!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!    actuel correspond a 3m de glace de mer, cf. L.Li
+!
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_lim(knindex(i),is_sic) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * dif_grnd(i) *RCPD/cal(i)
+       
+    ENDDO
+
+
+!****************************************************************************************
+! 5)
+! Return the new values for the seaice fraction
+!
+!****************************************************************************************
+
+    pctsrf_sic(:) = pctsrf_lim(:,is_sic)
+
+  END SUBROUTINE ocean_forced_ice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_get_vars(flux_o, flux_g)
+! Get some variables from module oceanforced.
+! This subroutine returns variables to a external routine
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Initialize the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_forced_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_forced_mod
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ocean_slab_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ocean_slab_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ocean_slab_mod.F90	(revision 984)
@@ -0,0 +1,644 @@
+!
+! $Header$
+!
+MODULE ocean_slab_mod
+!
+! This module is used for both surface ocean and sea-ice when using the slab ocean,
+! "ocean=slab".
+!
+  USE surface_data,     ONLY : tau_gl, calice, calsno
+  USE fonte_neige_mod,  ONLY : fonte_neige
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE dimphy
+  
+  IMPLICIT NONE
+
+  INTEGER, PRIVATE, SAVE                           :: lmt_pas, julien, idayvrai
+  !$OMP THREADPRIVATE(lmt_pas,julien,idayvrai)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_seaice
+  !$OMP THREADPRIVATE(tmp_seaice)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_tslab_loc
+  !$OMP THREADPRIVATE(tmp_tslab_loc)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slab_bils
+  !$OMP THREADPRIVATE(slab_bils)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE , SAVE  :: lmt_bils
+  !$OMP THREADPRIVATE(lmt_bils)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tmp_pctsrf_slab
+  !$OMP THREADPRIVATE(tmp_pctsrf_slab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_tslab
+  !$OMP THREADPRIVATE(tmp_tslab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_radsol
+  !$OMP THREADPRIVATE(tmp_radsol)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+  LOGICAL, PRIVATE, SAVE                           :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_init(dtime, tslab_rst, seaice_rst, pctsrf_rst)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+
+! Input variables
+!****************************************************************************************
+    REAL, INTENT(IN)                         :: dtime
+! Variables read from restart file
+    REAL, DIMENSION(klon), INTENT(IN)        :: tslab_rst          
+    REAL, DIMENSION(klon), INTENT(IN)        :: seaice_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf_rst
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: error
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'ocean_slab_intit'
+
+
+    WRITE(lunout,*) '************************'
+    WRITE(lunout,*) 'SLAB OCEAN est actif, prenez precautions !'
+    WRITE(lunout,*) '************************'    
+
+! Allocate variables initialize from restart fields
+    ALLOCATE(tmp_tslab(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_tslab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_tslab(:) = tslab_rst(:)
+
+    ALLOCATE(tmp_tslab_loc(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_tslab_loc'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_tslab_loc(:) = tslab_rst(:)
+
+    ALLOCATE(tmp_seaice(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_seaice'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_seaice(:) = seaice_rst(:)
+
+    ALLOCATE(tmp_pctsrf_slab(klon,nbsrf), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_pctsrf_slab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_pctsrf_slab(:,:) = pctsrf_rst(:,:)
+    
+! Allocate some other variables internal in module mod_oceanslab
+    ALLOCATE(tmp_radsol(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_radsol'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! a mettre un slab_bils aussi en force !!!
+    ALLOCATE(slab_bils(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slab_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    slab_bils(:) = 0.0   
+
+    ALLOCATE(lmt_bils(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation lmt_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+
+! pour une lecture une fois par jour    
+    lmt_pas = NINT(86400./dtime * 1.0) 
+
+  END SUBROUTINE ocean_slab_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_noice( & 
+       dtime, knon, knindex, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, agesno, &
+       qsurf, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+    
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)   :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: i
+    REAL, DIMENSION(klon)  :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)  :: tsurf_temp
+
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_slab_noice'    
+
+    tsurf_new(1:knon) = tmp_tslab(knindex(1:knon))
+    pctsrf_oce(:)   = tmp_pctsrf_slab(:,is_oce)
+    
+    tsurf_temp(:) = tsurf_new(:)
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    tmp_flux_o(:) = 0.0
+    tmp_radsol(:) = 0.0
+
+    DO i=1, knon
+       tmp_radsol(knindex(i))=radsol(i)
+       
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) &
+            tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+    ENDDO
+    
+  END SUBROUTINE ocean_slab_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_ice(   &
+       itime, dtime, jour, knon, knindex, &
+       debut, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, qsol, agesno, tsoil, &
+       alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+    LOGICAL, INTENT(IN)                  :: debut
+
+!In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)                :: alb_neig, tsurf_temp
+    REAL, DIMENSION(klon)                :: soilcap, soilflux
+    REAL, DIMENSION(klon)                :: zfra
+    REAL, PARAMETER                      :: t_grnd=271.35
+    REAL                                 :: amn, amx 
+    REAL, DIMENSION(klon)                :: tslab
+    REAL, DIMENSION(klon)                :: seaice ! glace de mer (kg/m2)
+    REAL, DIMENSION(klon,nbsrf)          :: pctsrf_new
+
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+! Initialization of output variables
+    alb1_new(:) = 0.0
+
+!****************************************************************************************
+! 
+!
+!****************************************************************************************
+    IF ( ok_slab_sicOBS) THEN   
+       ! glace de mer observee, lecture conditions limites
+       CALL interfoce_lim(itime, dtime, jour, & 
+            knon, knindex, &
+            debut, &
+            tsurf_new, pctsrf_new)
+
+       tmp_pctsrf_slab(:,:) = pctsrf_new(:,:)
+       WRITE(lunout,*) 'jour lecture pctsrf_new sic =',jour
+
+    ELSE
+       pctsrf_new=tmp_pctsrf_slab
+    ENDIF
+
+    DO i = 1, knon
+       tsurf_new(i) = tsurf(i)
+       IF (pctsrf_new(knindex(i),is_sic) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_new(i) = RTT - 1.8
+          IF (soil_model) tsoil(i,:) = RTT -1.8
+       ENDIF
+    ENDDO
+    
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_sic, knon, snow, tsurf_new, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+    tsurf_temp = tsurf_new
+    beta = 1.0
+
+!****************************************************************************************
+!
+!
+!****************************************************************************************
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_temp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+!****************************************************************************************
+!     calcul albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb1_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & 
+         0.6 * (1.0-zfra(1:knon))
+    
+    alb2_new(:) = alb1_new(:)
+
+!
+!IM: flux entre l'ocean et la glace de mer pour le "slab" ocean
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+!
+!IM: faire dependre le coefficient de conduction de la glace de mer
+!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!    actuel correspond a 3m de glace de mer, cf. L.Li
+!
+       IF ((cal(i).GT.1.0e-15) .AND. (pctsrf_new(knindex(i),is_sic) .GT. epsfra)) THEN
+          tmp_flux_g(knindex(i))=(tsurf_new(i)-t_grnd) &
+               * dif_grnd(i) *RCPD/cal(i)
+       ENDIF
+!
+!IM: Attention: ne pas initialiser le tmp_radsol puisque c'est deja fait sur is_oce;
+!IM:            tmp_radsol doit etre le flux solaire qui arrive sur l'ocean 
+!IM:            et non pas celui qui arrive sur la glace de mer
+    ENDDO
+    
+!
+! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean
+!
+
+    IF (check) THEN
+       amn=MIN(tmp_tslab(1),1000.)
+       amx=MAX(tmp_tslab(1),-1000.)
+       DO i=2, klon
+          amn=MIN(tmp_tslab(i),amn)
+          amx=MAX(tmp_tslab(i),amx)
+       ENDDO
+       
+       WRITE(lunout,*) ' debut avant interfoce_slab min max tmp_tslab',amn,amx
+    ENDIF !(check) THEN
+
+    tslab = tmp_tslab   
+
+    CALL interfoce_slab(klon, debut, itime, dtime, jour, &
+         tmp_radsol, tmp_flux_o, tmp_flux_g, tmp_pctsrf_slab, &
+         tslab, seaice, pctsrf_new)
+    
+    tmp_pctsrf_slab=pctsrf_new
+
+    DO i=1, knon
+       tmp_tslab(knindex(i))=tslab(knindex(i))
+    ENDDO
+     
+        
+!****************************************************************************************
+! Return the fraction of sea-ice
+! NB! jg : Peut-etre un probleme, faut-il prend aussi tmp_pctsrf_slab(:,is_oce)???
+!****************************************************************************************
+    pctsrf_sic(:) =  tmp_pctsrf_slab(:,is_sic)
+
+
+  END SUBROUTINE ocean_slab_ice
+! 
+!****************************************************************************************
+!
+  SUBROUTINE interfoce_slab(klon, debut, itap, dtime, ijour, &
+       radsol, fluxo, fluxg, pctsrf, &
+       tslab, seaice, pctsrf_slab)
+!
+! Cette routine calcule la temperature d'un slab ocean, la glace de mer 
+! et les pourcentages de la maille couverte par l'ocean libre et/ou 
+! la glace de mer pour un "slab" ocean de 50m
+!
+! Conception: Laurent Li
+! Re-ecriture + adaptation LMDZ4: I. Musat
+!
+! input:
+!   klon         nombre total de points de grille
+!   debut        logical: 1er appel a la physique
+!   itap         numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   ijour        jour dans l'annee en cours
+!   radsol       rayonnement net au sol (LW + SW)
+!   fluxo        flux turbulent (sensible + latent) sur les mailles oceaniques 
+!   fluxg        flux de conduction entre la surface de la glace de mer et l'ocean
+!   pctsrf       tableau des pourcentages de surface de chaque maille
+! output: 
+!   tslab        temperature de l'ocean libre
+!   seaice       glace de mer (kg/m2)
+!   pctsrf_slab  "pourcentages" (valeurs entre 0. et 1.) surfaces issus du slab
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: klon
+    LOGICAL, INTENT(IN)                       :: debut    ! not used
+    INTEGER, INTENT(IN)                       :: itap
+    REAL, INTENT(IN)                          :: dtime       ! not used
+    INTEGER, INTENT(IN)                       :: ijour
+    REAL, DIMENSION(klon), INTENT(IN)         :: radsol
+    REAL, DIMENSION(klon), INTENT(IN)         :: fluxo
+    REAL, DIMENSION(klon), INTENT(IN)         :: fluxg
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)  :: pctsrf
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tslab
+    REAL, DIMENSION(klon), INTENT(OUT)        :: seaice ! glace de mer (kg/m2)
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: pctsrf_slab
+
+! Local variables
+!****************************************************************************************
+    REAL                    :: amn, amx
+    REAL, PARAMETER         :: unjour=86400.
+    REAL, PARAMETER         :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K)
+    REAL, PARAMETER         :: cbing=0.334e+05        ! J/kg
+    REAL, DIMENSION(klon)   :: siceh !hauteur de la glace de mer (m)
+    INTEGER                 :: i
+    REAL                    :: zz, za, zb
+!
+!****************************************************************************************
+!
+    julien = MOD(ijour,360)
+
+    IF (check ) THEN
+       amn=MIN(tmp_tslab_loc(1),1000.)
+       amx=MAX(tmp_tslab_loc(1),-1000.)
+       DO i=2, klon
+          amn=MIN(tmp_tslab_loc(i),amn)
+          amx=MAX(tmp_tslab_loc(i),amx)
+       ENDDO
+
+       WRITE(lunout,*) ' debut min max tslab',amn,amx 
+       WRITE(lunout,*) ' itap,lmt_pas unjour',itap,lmt_pas,unjour
+    ENDIF
+
+    pctsrf_slab(1:klon,1:nbsrf) = pctsrf(1:klon,1:nbsrf)
+!
+! lecture du bilan au sol lmt_bils issu d'une simulation forcee en debut de journee
+! 
+    IF (MOD(itap,lmt_pas) .EQ. 1) THEN 
+       ! 1er pas de temps de la journee
+       idayvrai = ijour
+       CALL condsurf(julien,idayvrai, lmt_bils)
+    ENDIF
+
+    DO i = 1, klon
+       IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+            (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+!
+! fabriquer de la glace si congelation atteinte:
+!          
+          IF (tmp_tslab_loc(i).LT.(RTT-1.8)) THEN
+             zz =  (RTT-1.8)-tmp_tslab_loc(i)
+             tmp_seaice(i) = tmp_seaice(i) + cyang/cbing * zz
+             seaice(i) = tmp_seaice(i)
+             tmp_tslab_loc(i) = RTT-1.8
+          ENDIF
+!
+! faire fondre de la glace si temperature est superieure a 0:
+!
+          IF ((tmp_tslab_loc(i).GT.RTT) .AND. (tmp_seaice(i).GT.0.0)) THEN
+             zz = cyang/cbing * (tmp_tslab_loc(i)-RTT)
+             zz = MIN(zz,tmp_seaice(i))
+             tmp_seaice(i) = tmp_seaice(i) - zz
+             seaice(i) = tmp_seaice(i)
+             tmp_tslab_loc(i) = tmp_tslab_loc(i) - zz*cbing/cyang
+          ENDIF
+!
+! limiter la glace de mer a 10 metres (10000 kg/m2)
+!
+          IF(tmp_seaice(i).GT.45.) THEN
+             tmp_seaice(i) = MIN(tmp_seaice(i),10000.0)
+          ELSE
+             tmp_seaice(i) = 0. 
+          ENDIF
+          seaice(i) = tmp_seaice(i)
+          siceh(i)=tmp_seaice(i)/1000. !en metres
+!
+! determiner la nature du sol (glace de mer ou ocean libre):
+!
+! on fait dependre la fraction de seaice "pctsrf(i,is_sic)" 
+! de l'epaisseur de seaice :
+! pctsrf(i,is_sic)=1. si l'epaisseur de la glace de mer est >= a 20cm
+! et pctsrf(i,is_sic) croit lineairement avec seaice de 0. a 20cm d'epaisseur
+!
+
+          IF(.NOT.ok_slab_sicOBS) THEN
+             pctsrf_slab(i,is_sic)=MIN(siceh(i)/0.20, &
+                  1.-(pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)))
+             pctsrf_slab(i,is_oce)=1.0 - &
+                  (pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)+pctsrf_slab(i,is_sic))
+          ELSE
+             IF (i.EQ.1) WRITE(lunout,*) 'cas ok_slab_sicOBS TRUE : passe sur la modif.'
+          ENDIF !(.NOT.ok_slab_sicOBS) then
+       ENDIF !pctsrf
+    ENDDO
+!
+! Calculer le bilan du flux de chaleur au sol :
+!
+    DO i = 1, klon
+       za = radsol(i) + fluxo(i)
+       zb = fluxg(i)
+       IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+            (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+          slab_bils(i)=slab_bils(i)+(za*pctsrf_slab(i,is_oce) &
+               +zb*pctsrf_slab(i,is_sic))/ FLOAT(lmt_pas)
+       ENDIF
+    ENDDO !klon
+!
+! calcul tslab 
+!
+    IF (MOD(itap,lmt_pas).EQ.0) THEN !fin de journee
+!
+! calcul tslab 
+       amn=MIN(tmp_tslab_loc(1),1000.)
+       amx=MAX(tmp_tslab_loc(1),-1000.)
+       DO i = 1, klon
+          IF ((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+               (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+             tmp_tslab_loc(i) = tmp_tslab_loc(i) + &
+                  (slab_bils(i)-lmt_bils(i)) &
+                  /cyang*unjour
+
+! on remet l'accumulation a 0
+             slab_bils(i) = 0.
+          ENDIF !pctsrf
+!
+          IF (check) THEN
+             IF(i.EQ.1) THEN  
+                WRITE(lunout,*) 'i tmp_tslab_loc MOD(itap,lmt_pas).EQ.0 sicINTER',i,itap, &
+                     tmp_tslab_loc(i), tmp_seaice(i)
+             ENDIF
+             
+             amn=MIN(tmp_tslab_loc(i),amn)
+             amx=MAX(tmp_tslab_loc(i),amx)
+          ENDIF
+       ENDDO !klon
+    ENDIF !(MOD(itap,lmt_pas).EQ.0) THEN
+
+    IF ( check ) THEN
+       WRITE(lunout,*) 'fin min max tslab',amn,amx 
+    ENDIF
+
+    tslab  = tmp_tslab_loc
+    seaice = tmp_seaice
+
+  END SUBROUTINE interfoce_slab
+!
+!****************************************************************************************  
+!
+  SUBROUTINE ocean_slab_final(tslab_rst, seaice_rst)
+
+! This subroutine will send to phyredem the variables concerning the slab 
+! ocean that should be written to restart file.
+
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: tslab_rst
+    REAL, DIMENSION(klon), INTENT(OUT) :: seaice_rst
+
+!****************************************************************************************
+! Set the output variables
+    tslab_rst(:)  = tmp_tslab(:)
+!    tslab_rst(:)  = tmp_tslab_loc(:)
+    seaice_rst(:) = tmp_seaice(:)
+
+! Deallocation of all variables in module
+    DEALLOCATE(tmp_tslab, tmp_tslab_loc, tmp_pctsrf_slab)
+    DEALLOCATE(tmp_seaice, tmp_radsol, tmp_flux_o, tmp_flux_g)
+    DEALLOCATE(slab_bils, lmt_bils)
+
+  END SUBROUTINE ocean_slab_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_get_vars(tslab_loc, seaice_loc, flux_o_loc, flux_g_loc)
+! "Get some variables from module ocean_slab_mod"
+! This subroutine prints variables to a external routine
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: tslab_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: seaice_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g_loc
+
+! Set the output variables
+    tslab_loc(:)  = tmp_tslab(:)
+    seaice_loc(:) = tmp_seaice(:)
+    flux_o_loc(:) = tmp_flux_o(:)
+    flux_g_loc(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_slab_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_slab_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/orbite.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/orbite.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/orbite.F	(revision 984)
@@ -0,0 +1,325 @@
+!
+! $Header$
+!
+c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+c Objet: pour un jour donne, calculer la longitude vraie de la terre
+c        (par rapport au point vernal-21 mars) dans son orbite solaire
+c        calculer aussi la distance terre-soleil (unite astronomique)
+c======================================================================
+c Arguments:
+c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+c                  vernal (21 mars) en degres
+c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+c======================================================================
+#include "YOMCST.h"
+C
+C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)
+     .     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)
+     .     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)
+     .         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)
+     .         +13.0/12.0*xee*SIN(3.0*ranm)
+c
+      anv=ranv/pir
+      longi=anv+xl
+C
+      dist = (1-R_ecc*R_ecc)
+     .      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END
+c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+c======================================================================
+c Arguments:
+c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+c                   solaire a partir de l'equinoxe de printemps (degre)
+c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+c                   par 24 heures (unite en fraction de 0 a 1)
+c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+c                   la journee (0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+c
+      IF ( lat .GE. (pi_local/2.+lat_sun)
+     .    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)
+     .          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+c
+      frac(i) = omega / pi_local
+c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)
+     .          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,
+     s                  pmu0,frac)
+      USE dimphy
+      IMPLICIT none
+c=============================================================
+c Auteur : O. Boucher (LMD/CNRS)
+c          d'apres les routines zenith et angle de Z.X. Li 
+c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+c          connaissant la declinaison, la latitude et la longitude.
+c Rque   : Different de la routine angle en ce sens que zenang 
+c          fournit des moyennes de pmu0 et non des valeurs 
+c          instantanees, du coup frac prend toutes les valeurs 
+c          entre 0 et 1.
+c Date   : premiere version le 13 decembre 1994
+c          revu pour  GCM  le 30 septembre 1996
+c===============================================================
+c longi----INPUT : la longitude vraie de la terre dans son plan
+c                  solaire a partir de l'equinoxe de printemps (degre)
+c gmtime---INPUT : temps universel en fraction de jour
+c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+c lat------INPUT : latitude en degres
+c long-----INPUT : longitude en degres
+c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+c================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c================================================================
+      real longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+c omega : heure en radian du coucher de soleil 
+c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+c================================================================
+c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+c
+      DO i = 1, klon
+c
+      latr = lat(i) * pi_local / 180.
+c
+c--pose probleme quand lat=+/-90 degres
+c
+c      omega = -TAN(latr)*TAN(lat_sun)
+c      omega = ACOS(omega)
+c      IF (latr.GE.(pi_local/2.+lat_sun)
+c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+c         omega = 0.0       ! nuit polaire
+c      ENDIF
+c      IF (latr.GE.(pi_local/2.-lat_sun)
+c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+c         omega = pi_local  ! journee polaire
+c      ENDIF
+c
+c--remplace par cela (le cas par defaut est different)
+c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)
+     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.
+     .    latr.GT.(-pi_local/2.+lat_sun).AND.
+     .    latr.LT.(pi_local/2.-lat_sun).AND.
+     .    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega
+     .                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) + 
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)        
+      ENDIF
+c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+c
+c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)
+      ENDIF 
+c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +
+     .           COS(latr)*COS(lat_sun)*
+     .           (SIN(omegafin)-SIN(omegadeb))/
+     .           (omegafin-omegadeb)
+c
+      ENDIF
+c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+c
+      ENDIF   !---comparaison omega1 et omega2
+c
+      ENDDO
+c
+      END
+c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,
+     s                   pmu0, fract)
+      USE dimphy
+      IMPLICIT none
+c
+c Auteur(s): Z.X. Li (LMD/ENS)
+c
+c Objet: calculer le cosinus de l'angle zenithal du soleil en
+c        connaissant la declinaison du soleil, la latitude et la
+c        longitude du point sur la terre, et le temps universel
+c
+c Arguments d'entree:
+c     longi  : declinaison du soleil (en degres)
+c     gmtime : temps universel en second qui varie entre 0 et 86400
+c     lat    : latitude en degres
+c     long   : longitude en degres
+c Arguments de sortie:
+c     pmu0   : cosinus de l'angle zenithal
+c
+c====================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+c
+      incl=R_incl * zpir
+c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+c--initialisation a la nuit
+c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+c
+c 1 degre en longitude = 240 secondes en temps
+c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)
+     .           + cos(lat(n)*zpir) * cos(lat_sun)
+     .           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/orografi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/orografi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/orografi.F	(revision 984)
@@ -0,0 +1,1839 @@
+!
+! $Header$
+!
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature             
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG  .                +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG  .                +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE orodrag( nlon,nlev 
+     i                 , kgwd, kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+
+      USE dimphy
+      implicit none
+
+c
+c
+c**** *gwdrag* - does the gravity wave parametrization.
+c
+c     purpose.
+c     --------
+c
+c          this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves
+c
+c**   interface.
+c     ----------
+c          called from *callpar*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c      implicit logical (l)
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+c
+cym      integer nlon, nlev, klevm1
+      integer nlon, nlev
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(klon),
+     *      pvlow(klon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     $       ztauf(klon,klev+1),
+     *       zstab(klon,klev+1),
+     *       zvph(klon,klev+1),
+     *       zrho(klon,klev+1),
+     *       zri(klon,klev+1),
+     *       zpsi(klon,klev+1),
+     *       zzdep(klon,klev)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+cym      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+  200 continue
+c
+c
+c
+      call orosetup
+     *     ( nlon, ktest 
+     *     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress
+     *    ( nlon  , nlev
+     *    , ktest , icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic
+     *    , ztau 
+     *    , pgeom1,zdmod)
+c
+c
+c*         4.      compute stress profile.
+c*                 ------- ------ --------
+c
+  400 continue
+c
+c
+      call gwprofil
+     *       (  nlon , nlev
+     *       , kgwd   , kdx , ktest
+     *       , ikcrith, icrit
+     *       , paphm1, zrho   , zstab ,  zvph
+     *       , zri   , ztau   
+     *       , zdmod , psig  , pstd)
+c
+c
+c*         5.      compute tendencies.
+c*                 -------------------
+c
+  500 continue
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+      ilevp1=klev+1
+c
+c
+      do 524 jk=1,klev
+c
+c
+c     do 523 jl=1,kgwd
+c     ji=kdx(jl)
+c  Modif vectorisation 02/04/2004
+      do 523 ji=kidia,kfdia
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c controle des overshoots:
+c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c fin du controle des overshoots
+c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c simplement oppose au vent
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c  projection dans la direction de l'axe principal de l'orographie
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c     pte(ji,jk)=zdtdt(ji)
+c
+c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+c
+      pte(ji,jk)=0.0
+
+      endif
+  523 continue
+
+  524 continue
+c
+c
+      return
+      end
+      SUBROUTINE orosetup
+     *         ( nlon   , ktest
+     *         , kkcrit, kkcrith, kcrit
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgamma, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+c
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+c
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c
+c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c     print *,' entree gwsetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+c
+      zcons1=1./rd
+cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+c
+
+ 210  continue
+c
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define low-level flow
+c      ---------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define blocked flow
+c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+c
+c*******  setup orography axes and define plane of profiles  *******
+c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+c
+c  ************ define flow in plane of lowlevel stress *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c
+c*         2.2     brunt-vaisala frequency and density at half levels.
+c
+  220 continue
+c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*
+     *                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)
+     *                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+c
+c*         2.3     mean flow richardson number.
+c*                 and critical height for froude layer
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for the breaking
+c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,
+     *          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end
+      SUBROUTINE gwstress
+     *         (  nlon  , nlev
+     *         , ktest, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic  , ptau  
+     *         , pgeom1 , pdmod )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon, nlev
+      integer kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2
+     *    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+     *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+c
+      return
+      end
+      SUBROUTINE GWPROFIL
+     *         ( NLON, NLEV
+     *         , kgwd, kdx , ktest
+     *         , KKCRITH, KCRIT
+     *         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU
+     *         , pdmod   , psig , pvar)
+
+C**** *GWPROFIL*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *GWDRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD:
+C     -------
+C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+C     NONLINEAR GRAVITY WAVE BREAKING.
+C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+C     
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+C-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+C
+
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)
+     *       ,kdx(nlon) , ktest(nlon)
+
+C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),
+     *     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),
+     *     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)
+     
+      REAL pdmod (NLON) , psig(NLON),
+     *     pvar(NLON)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
+      REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
+      REAL ZTAU (KLON,KLEV+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+c      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      ilevh=KLEV/3
+C
+c     DO 400 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      DO 400 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+      endif
+  400 CONTINUE
+  
+C
+      DO 430 JK=KLEV,2,-1
+C
+C
+C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+C                 BLOCKING LAYER.
+  410 CONTINUE
+C
+c     DO 411 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 411 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+C          ENDIF
+C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+      endif
+ 411  CONTINUE             
+C
+C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+C        
+C
+C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+C
+  420 CONTINUE
+C
+c     DO 421 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 421 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)
+     *                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+      endif
+  421 CONTINUE
+C
+C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+C                 LEVEL
+C
+                          
+c     DO 431 ji=1,kgwd
+c     jl=Kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 431 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+      endif
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+c     DO 530 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+      endif
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+c     DO 532 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +
+     .                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*
+     .                ZDELP/ZDELPT
+     
+        ENDIF
+            
+      endif
+ 532  CONTINUE    
+ 
+C  REORGANISATION IN THE STRATOSPHERE
+
+c     DO 533 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+      endif
+ 533  CONTINUE
+
+C REORGANISATION IN THE TROPOSPHERE
+
+c      DO 534 ji=1,kgwd
+c      jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 534 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +
+     *                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP
+     .                                                     /ZDELPT
+
+       ENDIF
+      endif
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,      
+     e                   plat,pmea,pstd, ppic,
+     e                   ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL OROLIFT(klon,klev,ktest,
+     .            dtime,
+     .            papmh, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, ppic,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG .                 +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG .                 +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE OROLIFT( NLON,NLEV
+     I                 , KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PLAT
+     R                 , PMEA, PVAROR, ppic
+C OUTPUTS
+     R                 , PULOW,PVLOW
+     R                 , PVOM,PVOL,PTE )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+      USE dimphy
+      implicit none
+C
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),
+     *      PVOL(NLON,NLEV),
+     *      PVOM(NLON,NLEV),
+     *      PULOW(NLON),
+     *      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),
+     *      PVM1(NLON,NLEV),
+     *      PTM1(NLON,NLEV),
+     *      PLAT(NLON),PMEA(NLON),
+     *      PVAROR(NLON),
+     *      ppic(NLON),
+     *      PGEOM1(NLON,NLEV),
+     *      PAPHM1(NLON,NLEV+1)
+C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      logical lifthigh
+cym      integer klevm1, jl, ilevh, jk
+      integer  jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER  
+     *         IKNUB(klon),
+     *         IKNUL(klon)
+      LOGICAL LL1(KLON,KLEV+1)
+C
+      REAL   ZTAU(KLON,KLEV+1),
+     *       ZTAV(KLON,KLEV+1),
+     *       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),
+     *       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+C-----------------------------------------------------------------------
+C
+C*         1.1  INITIALIZATIONS
+C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)STOP
+      ZCONS1=1./RD
+cym      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+C     do 2011 jl=kidia,kfdia
+C     IF(KTEST(JL).EQ.1) THEN
+C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+C     ENDIF
+C2011 continue
+
+C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 223'
+
+C********************************************************************
+C
+C*     DEFINE LOW LEVEL FLOW
+C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)
+     *               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 CONTINUE
+C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      IF(LIFTHIGH)THEN
+C
+  500 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 500'
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END
+
+
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+c      USE parallel
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PSIG        : VERTICAL COORDINATE TABLE
+C        NLEV        : NUMBER OF MODEL LEVELS
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C        ECMWF Research Department documentation of the IFS
+C
+C     AUTHOR.
+C     -------
+C        MARTIN MILLER             *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01
+C     ------------------------------------------------------------------
+      implicit none
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+      integer nlon,nlev, jk
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+C
+C*       1.    SET THE VALUES OF THE PARAMETERS
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+      
+            
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+
+
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+C
+      GKLIFT=0.50  
+      GVCRIT =0.0
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=1.E-12
+C
+      GTSEC=1.E-07
+C
+C      ----------------------------------------------------------------
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ozonecm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ozonecm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ozonecm.F	(revision 984)
@@ -0,0 +1,89 @@
+!
+! $Header$
+!
+      SUBROUTINE ozonecm(rjour, rlat, paprs, o3)
+      USE dimphy
+      IMPLICIT none
+C
+C The ozone climatology is based on an analytic formula which fits the
+C Krueger and Mintzner (1976) profile, as well as the variations with
+C altitude and latitude of the maximum ozone concentrations and the total
+C column ozone concentration of Keating and Young (1986). The analytic
+C formula have been established by J-F Royer (CRNM, Meteo France), who
+C also provided us the code.
+C
+C A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the
+C 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976).
+C
+C Keating, G. M. and D. F. Young, 1985: Interim reference models for the
+C middle atmosphere, Handbook for MAP, vol. 16, 205-229.
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+#include "YOMCST.h"
+      REAL rlat(klon), paprs(klon,klev+1)
+      REAL o3(klon,klev)   ! ozone concentration in kg/kg
+      REAL tozon, rjour, pi, pl
+      INTEGER i, k
+C----------------------------------------------------------
+      REAL field(klon,klev+1)
+      REAL ps
+      PARAMETER (ps=101325.0)
+      REAL an, unit, zo3q3
+      SAVE an, unit, zo3q3
+c$OMP THREADPRIVATE(an, unit, zo3q3)
+      REAL mu,gms, zslat, zsint, zcost, z, ppm, qpm, a
+      REAL asec, bsec, aprim, zo3a3
+C----------------------------------------------------------
+c         data an /365.25/   (meteo)
+      DATA an /360.00/
+      DATA unit /2.1415e-05/
+      DATA zo3q3 /4.0e-08/
+
+      pi = 4.0 * ATAN(1.0)
+      DO k = 1, klev
+      DO i = 1, klon
+      zslat = SIN(pi/180.*rlat(i))
+      zsint = SIN(2.*pi*(rjour+15.)/an)
+      zcost = COS(2.*pi*(rjour+15.)/an)
+      z = 0.0531+zsint*(-0.001595+0.009443*zslat) +
+     .  zcost*(-0.001344-0.00346*zslat) +
+     .  zslat**2*(.056222+zslat**2*(-.037609
+     . +.012248*zsint+.00521*zcost+.008890*zslat))
+      zo3a3 = zo3q3/ps/2.
+      z = z-zo3q3*ps
+      gms = z
+      mu = ABS(sin(pi/180.*rlat(i)))
+      ppm = 800.-(500.*zslat+150.*zcost)*zslat
+      qpm = 1.74e-5-(7.5e-6*zslat+1.7e-6*zcost)*zslat
+      bsec = 2650.+5000.*zslat**2
+      a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
+      a = a/(bsec**(3./2.)+ppm**(3./2.))**2
+      aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
+      aprim = amax1(0.,aprim)
+      asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
+      asec = AMAX1(0.0,asec)
+      aprim = gms-asec/(1.+(bsec/ps)**(3./2.))
+      pl = paprs(i,k)
+      tozon = aprim/(1.+3.*(ppm/pl)**2)+asec/(1.+(bsec/pl)**(3./2.))
+     .  + zo3a3*pl*pl
+      tozon = tozon / 9.81  ! en kg/m**2
+      tozon = tozon / unit  ! en kg/m**2  > u dobson (10e-5 m)
+      tozon = tozon / 1000. ! en cm
+      field(i,k) = tozon
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         field(i,klev+1) = 0.0
+      ENDDO
+      DO k = 1, klev
+        DO i = 1, klon
+          o3(i,k) = field(i,k) - field(i,k+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/pbl_surface_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/pbl_surface_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/pbl_surface_mod.F90	(revision 984)
@@ -0,0 +1,1324 @@
+!
+! $Header$
+!
+MODULE pbl_surface_mod
+!
+! Planetary Boundary Layer and Surface module
+!
+! This module manage the calculation of turbulent diffusion in the boundary layer 
+! and all interactions towards the differents sub-surfaces.
+!
+!
+  USE dimphy
+  USE mod_phys_lmdz_para,  ONLY : mpi_size
+  USE ioipsl
+  USE surface_data,        ONLY : ocean, ok_veget
+  USE surf_land_mod,       ONLY : surf_land
+  USE surf_landice_mod,    ONLY : surf_landice
+  USE surf_ocean_mod,      ONLY : surf_ocean
+  USE surf_seaice_mod,     ONLY : surf_seaice
+  USE cpl_mod,             ONLY : gath2cpl
+  USE climb_hq_mod,        ONLY : climb_hq_down, climb_hq_up
+  USE climb_wind_mod,      ONLY : climb_wind_down, climb_wind_up
+  USE coef_diff_turb_mod,  ONLY : coef_diff_turb
+
+  IMPLICIT NONE
+
+! 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)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: snow   ! snow at surface
+  !$OMP THREADPRIVATE(snow)
+  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)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: ftsoil ! soil temperature
+  !$OMP THREADPRIVATE(ftsoil)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,&
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+! This routine should be called after the restart file has been read.
+! This routine initialize the restart variables and does some validation tests
+! for the index of the different surfaces and tests the choice of type of ocean.
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "iniprint.h"
+ 
+! 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
+
+  
+! Local variables
+!****************************************************************************************
+    INTEGER                       :: ierr
+    CHARACTER(len=80)             :: abort_message
+    CHARACTER(len = 20)           :: modname = 'pbl_surface_init'
+    
+
+!****************************************************************************************
+! Allocate and initialize module variables with fields read from restart file.
+!
+!****************************************************************************************    
+    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)
+
+    ALLOCATE(snow(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(qsurf(klon,nbsrf), stat=ierr)
+    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(:,:,:)
+
+
+!****************************************************************************************
+! Test for sub-surface indices
+!
+!****************************************************************************************
+    IF (is_ter /= 1) THEN 
+      WRITE(lunout,*)" *** Warning ***"
+      WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter
+      WRITE(lunout,*)"or on doit commencer par les surfaces continentales"
+      abort_message="voir ci-dessus"
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_oce > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' l''ocean doit etre traite avant la banquise'
+      WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_lic > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer'
+      WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Validation of ocean mode
+!
+!****************************************************************************************
+
+    IF (ocean /= 'slab  ' .AND. ocean /= 'force ' .AND. ocean /= 'couple') THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)'Option couplage pour l''ocean = ', ocean
+      abort_message='option pour l''ocean non valable'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Test of coherence between variable ok_veget and cpp key CPP_VEGET
+!
+!****************************************************************************************
+    IF (ok_veget) THEN
+#ifndef CPP_VEGET
+       abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.'
+       CALL abort_gcm(modname,abort_message,1)
+#endif
+    ENDIF
+
+
+  END SUBROUTINE pbl_surface_init
+!  
+!****************************************************************************************
+!  
+
+  SUBROUTINE pbl_surface( &
+       dtime,     date0,     itap,     jour,          &
+       debut,     lafin,                              &
+       rlon,      rlat,      rugoro,   rmu0,          &
+       rain_f,    snow_f,    solsw_m,  sollw_m,       &
+       t,         q,         u,        v,             &
+       pplay,     paprs,     pctsrf,                  &
+       ts,        alb1,      alb2,     u10m,   v10m,  &
+       lwdown_m,  cdragh,    cdragm,   zu1,    zv1,   &
+       alb1_m,    alb2_m,    zxsens,   zxevap,        &
+       zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
+       d_t,       d_q,       d_u,      d_v,           & 
+       zcoefh,    pctsrf_new,                         &
+       qsol_d,    zq2m,      s_pblh,   s_plcl,        &
+       s_capCL,   s_oliqCL,  s_cteiCL, s_pblT,        &
+       s_therm,   s_trmb1,   s_trmb2,  s_trmb3,       &
+       zxrugs,    zu10m,     zv10m,    fder_print,    &
+       zxqsurf,   rh2m,      zxfluxu,  zxfluxv,       &
+       rugos_d,   agesno_d,  sollw,    solsw,         &
+       d_ts,      evap_d,    fluxlat,  t2m,           &
+       wfbils,    wfbilo,    flux_t,   flux_u, flux_v,&
+       dflux_t,   dflux_q,   zxsnow,                  &
+       zxfluxt,   zxfluxq,   q2m,      flux_q, tke    )
+!****************************************************************************************
+! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+! Objet: interface de "couche limite" (diffusion verticale)
+!
+!AA REM:
+!AA-----
+!AA Tout ce qui a trait au traceurs est dans phytrac maintenant
+!AA pour l'instant le calcul de la couche limite pour les traceurs
+!AA se fait avec cltrac et ne tient pas compte de la differentiation
+!AA des sous-fraction de sol.
+!AA REM bis :
+!AA----------
+!AA Pour pouvoir extraire les coefficient d'echanges et le vent 
+!AA dans la premiere couche, 3 champs supplementaires ont ete crees
+!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
+!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir 
+!AA si les informations des subsurfaces doivent etre prises en compte
+!AA il faudra sortir ces memes champs en leur ajoutant une dimension, 
+!AA c'est a dire nbsrf (nbre de subsurface).
+!
+! Arguments:
+!
+! dtime----input-R- interval du temps (secondes)
+! itap-----input-I- numero du pas de temps
+! date0----input-R- jour initial
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! ts-------input-R- temperature du sol (en Kelvin)
+! paprs----input-R- pression a intercouche (Pa)
+! pplay----input-R- pression au milieu de couche (Pa)
+! rlat-----input-R- latitude en degree
+! rugos----input-R- longeur de rugosite (en m)
+!
+! d_t------output-R- le changement pour "t"
+! d_q------output-R- le changement pour "q"
+! d_u------output-R- le changement pour "u"
+! d_v------output-R- le changement pour "v"
+! d_ts-----output-R- le changement pour "ts"
+! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)
+!                    (orientation positive vers le bas)
+! tke---input/output-R- tke (kg/m**2/s)
+! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
+! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
+! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
+! dflux_t--output-R- derive du flux sensible
+! dflux_q--output-R- derive du flux latent
+! zu1------output-R- le vent dans la premiere couche
+! zv1------output-R- le vent dans la premiere couche
+! trmb1----output-R- deep_cape
+! trmb2----output-R- inhibition 
+! trmb3----output-R- Point Omega
+! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL
+! plcl-----output-R- Niveau de condensation
+! pblh-----output-R- HCL
+! pblT-----output-R- T au nveau HCL
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+    INCLUDE "dimensions.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "temps.h"
+    INCLUDE "control.h"
+
+! Input variables
+!****************************************************************************************
+    REAL,                         INTENT(IN)        :: dtime   ! time interval (s)
+    REAL,                         INTENT(IN)        :: date0   ! initial day
+    INTEGER,                      INTENT(IN)        :: itap    ! time step
+    INTEGER,                      INTENT(IN)        :: jour    ! current day of the year
+    LOGICAL,                      INTENT(IN)        :: debut   ! true if first run step
+    LOGICAL,                      INTENT(IN)        :: lafin   ! true if last run step
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rlon    ! longitudes in degrees
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rlat    ! latitudes in degrees
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rugoro  ! rugosity length
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rmu0    ! cosine of solar zenith angle
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rain_f  ! rain fall
+    REAL, DIMENSION(klon),        INTENT(IN)        :: snow_f  ! snow fall
+    REAL, DIMENSION(klon),        INTENT(IN)        :: solsw_m ! net shortwave radiation at mean surface
+    REAL, DIMENSION(klon),        INTENT(IN)        :: sollw_m ! net longwave radiation at mean surface
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: t       ! temperature (K)
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: q       ! water vapour (kg/kg)
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: u       ! u speed
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: v       ! v speed
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: pplay   ! mid-layer pression (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)        :: paprs   ! pression between layers (Pa) 
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)        :: pctsrf  ! sub-surface fraction
+
+! Input/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: ts      ! temperature at surface (K)
+    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(klon, nbsrf), INTENT(INOUT)     :: u10m    ! u speed at 10m
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: v10m    ! v speed at 10m
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: lwdown_m   ! Downcoming longwave radiation
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: cdragh     ! drag coefficient for T and Q
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: cdragm     ! drag coefficient for wind
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu1        ! u wind speed in first layer
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1        ! v wind speed in first layer
+    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),        INTENT(OUT)       :: zxsens     ! sensible heat flux at surface with inversed sign 
+                                                                  ! (=> positive sign upwards)
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxevap     ! water vapour flux at surface, positiv upwards
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxtsol     ! temperature at surface, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxfluxlat  ! latent flux, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zt2m       ! temperature at 2m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsat2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_t        ! change in temperature 
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_q        ! change in water vapour
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_u        ! change in u speed
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_v        ! change in v speed
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zcoefh     ! coef for turbulent diffusion of T and Q, mean for each grid point
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: pctsrf_new ! new sub-surface fraction
+
+! Output only for diagnostics
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol_d     ! 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)
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_plcl     ! condensation level
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_capCL    ! CAPE of PBL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_oliqCL   ! liquid water intergral of PBL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_cteiCL   ! cloud top instab. crit. of PBL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblT     ! temperature at PBLH
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_therm    ! thermal virtual temperature excess
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb1    ! deep cape, mean for each grid point
+    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)       :: zu10m      ! u speed at 10m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv10m      ! v speed at 10m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: fder_print ! fder for printing (=fder(i) + dflux_t(i) + dflux_q(i))
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxqsurf    ! humidity at surface, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: rh2m       ! relative humidity at 2m
+    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), 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(OUT)       :: fluxlat    ! latent flux
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: t2m        ! temperature at 2 meter height
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: wfbils     ! heat balance at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: wfbilo     ! water balance at surface
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t     ! sensible heat flux (CpT) J/m**2/s (W/m**2)
+                                                                  ! positve orientation downwards
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u     ! u wind tension (kg m/s)/(m**2 s) or Pascal
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v     ! v wind tension (kg m/s)/(m**2 s) or Pascal
+
+! Output not needed
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: dflux_t    ! change of sensible heat flux 
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: dflux_q    ! change of water vapour flux
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: zxsnow     ! snow at surface, mean for each grid point
+    REAL, DIMENSION(klon, klev), INTENT(OUT)        :: zxfluxt    ! sensible heat flux, mean for each grid point
+    REAL, DIMENSION(klon, klev), INTENT(OUT)        :: zxfluxq    ! water vapour flux, mean for each grid point
+    REAL, DIMENSION(klon, nbsrf),INTENT(OUT)        :: q2m        ! water vapour at 2 meter height
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q     ! water vapour flux(latent flux) (kg/m**2/s)
+
+! Input/output
+    REAL, DIMENSION(klon, klev+1, nbsrf), INTENT(INOUT) :: tke
+
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER, SAVE                            :: nhoridbg, nidbg   ! variables for IOIPSL
+!$OMP THREADPRIVATE(nhoridbg, nidbg)
+    LOGICAL, SAVE                            :: debugindex=.FALSE.
+!$OMP THREADPRIVATE(debugindex)
+    LOGICAL, SAVE                            :: first_call=.TRUE.
+!$OMP THREADPRIVATE(first_call)
+    CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf
+!$OMP THREADPRIVATE(cl_surf)
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                            :: i, k, nsrf 
+    INTEGER                            :: knon, j
+    INTEGER                            :: idayref
+    INTEGER , DIMENSION(klon)          :: ni
+    REAL                               :: zx_alf1, zx_alf2 !valeur ambiante par extrapola
+    REAL                               :: amn, amx
+    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)              :: yalb, yalb1, yalb2
+    REAL, DIMENSION(klon)              :: yu1, yv1
+    REAL, DIMENSION(klon)              :: ysnow, yqsurf, yagesno, yqsol
+    REAL, DIMENSION(klon)              :: yrain_f, ysnow_f
+    REAL, DIMENSION(klon)              :: ysolsw, ysollw
+    REAL, DIMENSION(klon)              :: yfder
+    REAL, DIMENSION(klon)              :: yrugoro
+    REAL, DIMENSION(klon)              :: yfluxlat
+    REAL, DIMENSION(klon)              :: y_d_ts
+    REAL, DIMENSION(klon)              :: y_flux_t1, y_flux_q1
+    REAL, DIMENSION(klon)              :: y_dflux_t, y_dflux_q
+    REAL, DIMENSION(klon)              :: u1lay, v1lay
+    REAL, DIMENSION(klon)              :: yt2m, yq2m, yu10m
+    REAL, DIMENSION(klon)              :: yustar
+    REAL, DIMENSION(klon)              :: yu10mx
+    REAL, DIMENSION(klon)              :: yu10my
+    REAL, DIMENSION(klon)              :: ywindsp
+    REAL, DIMENSION(klon)              :: yt10m, yq10m
+    REAL, DIMENSION(klon)              :: ypblh
+    REAL, DIMENSION(klon)              :: ylcl
+    REAL, DIMENSION(klon)              :: ycapCL
+    REAL, DIMENSION(klon)              :: yoliqCL
+    REAL, DIMENSION(klon)              :: ycteiCL
+    REAL, DIMENSION(klon)              :: ypblT
+    REAL, DIMENSION(klon)              :: ytherm
+    REAL, DIMENSION(klon)              :: ytrmb1
+    REAL, DIMENSION(klon)              :: ytrmb2
+    REAL, DIMENSION(klon)              :: ytrmb3
+    REAL, DIMENSION(klon)              :: uzon, vmer
+    REAL, DIMENSION(klon)              :: tair1, qair1, tairsol
+    REAL, DIMENSION(klon)              :: psfce, patm
+    REAL, DIMENSION(klon)              :: qairsol, zgeo1
+    REAL, DIMENSION(klon)              :: rugo1
+    REAL, DIMENSION(klon)              :: yfluxsens
+    REAL, DIMENSION(klon)              :: petAcoef, peqAcoef, petBcoef, peqBcoef
+    REAL, DIMENSION(klon)              :: ypsref
+    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb1_new, yalb2_new
+    REAL, DIMENSION(klon)              :: pctsrf_nsrf
+    REAL, DIMENSION(klon)              :: ztsol
+    REAL, DIMENSION(klon)              :: alb_m  ! mean albedo for whole SW interval
+    REAL, DIMENSION(klon,klev)         :: y_d_t, y_d_q
+    REAL, DIMENSION(klon,klev)         :: y_d_u, y_d_v
+    REAL, DIMENSION(klon,klev)         :: y_flux_t, y_flux_q
+    REAL, DIMENSION(klon,klev)         :: y_flux_u, y_flux_v
+    REAL, DIMENSION(klon,klev)         :: ycoefh, ycoefm
+    REAL, DIMENSION(klon,klev)         :: yu, yv
+    REAL, DIMENSION(klon,klev)         :: yt, yq
+    REAL, DIMENSION(klon,klev)         :: ypplay, ydelp
+    REAL, DIMENSION(klon,klev)         :: delp
+    REAL, DIMENSION(klon,klev+1)       :: ypaprs
+    REAL, DIMENSION(klon,klev+1)       :: ytke
+    REAL, DIMENSION(klon,nsoilmx)      :: ytsoil
+    REAL, DIMENSION(klon,nbsrf)        :: pctsrf_pot
+    CHARACTER(len=80)                  :: abort_message
+    CHARACTER(len=20)                  :: modname = 'pbl_surface'
+    LOGICAL, PARAMETER                 :: zxli=.FALSE. ! utiliser un jeu de fonctions simples
+    LOGICAL, PARAMETER                 :: check=.FALSE.
+
+! For debugging with IOIPSL
+    INTEGER, DIMENSION(iim*(jjm+1))    :: ndexbg
+    REAL                               :: zjulian
+    REAL, DIMENSION(klon)              :: tabindx
+    REAL, DIMENSION(iim,jjm+1)         :: zx_lon, zx_lat
+    REAL, DIMENSION(iim,jjm+1)         :: debugtab
+
+
+    REAL, DIMENSION(klon,nbsrf)        :: pblh         ! height of the planetary boundary layer
+    REAL, DIMENSION(klon,nbsrf)        :: plcl         ! condensation level
+    REAL, DIMENSION(klon,nbsrf)        :: capCL
+    REAL, DIMENSION(klon,nbsrf)        :: oliqCL
+    REAL, DIMENSION(klon,nbsrf)        :: cteiCL
+    REAL, DIMENSION(klon,nbsrf)        :: pblT
+    REAL, DIMENSION(klon,nbsrf)        :: therm
+    REAL, DIMENSION(klon,nbsrf)        :: trmb1        ! deep cape
+    REAL, DIMENSION(klon,nbsrf)        :: trmb2        ! inhibition
+    REAL, DIMENSION(klon,nbsrf)        :: trmb3        ! point Omega
+    REAL, DIMENSION(klon,nbsrf)        :: zx_rh2m, zx_qsat2m
+    REAL, DIMENSION(klon,nbsrf)        :: zx_qs1, zx_t1
+    REAL, DIMENSION(klon,nbsrf)        :: zdelta1, zcor1
+    REAL, DIMENSION(klon, nbsrf)       :: alb          ! mean albedo for whole SW interval
+    REAL, DIMENSION(klon)              :: ylwdown      ! jg : temporary (ysollwdown)
+
+
+!jg+ temporary test
+    REAL, DIMENSION(klon,klev)         :: y_flux_u_old, y_flux_v_old
+    REAL, DIMENSION(klon,klev)         :: y_d_u_old, y_d_v_old
+!jg-
+    
+!****************************************************************************************
+! Declarations specifiques pour le 1D. A reprendre 
+  REAL  :: fsens,flat
+  LOGICAL ok_flux_surf
+  data ok_flux_surf/.false./
+    common /flux_arp/fsens,flat,ok_flux_surf
+
+!****************************************************************************************
+! End of declarations
+!****************************************************************************************
+
+
+!****************************************************************************************
+! 1) Initialisation and validation tests 
+!    Only done first time entering this subroutine
+!
+!****************************************************************************************
+
+
+    IF (first_call) THEN
+       first_call=.FALSE.
+      
+       ! Initilize debug IO
+       IF (debugindex .AND. mpi_size==1) THEN 
+          ! initialize IOIPSL output
+          idayref = day_ini
+          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+          DO i = 1, iim
+             zx_lon(i,1) = rlon(i+1)
+             zx_lon(i,jjm+1) = rlon(i+1)
+          ENDDO
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+          CALL histbeg("sous_index", iim,zx_lon(:,1),jjm+1,zx_lat(1,:), &
+               1,iim,1,jjm+1, &
+               itau_phy,zjulian,dtime,nhoridbg,nidbg) 
+          ! no vertical axis
+          cl_surf(1)='ter'
+          cl_surf(2)='lic'
+          cl_surf(3)='oce'
+          cl_surf(4)='sic'
+          DO nsrf=1,nbsrf
+             CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim, &
+                  jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) 
+          END DO
+
+          CALL histend(nidbg)
+          CALL histsync(nidbg)
+
+       END IF
+       
+    ENDIF
+          
+!****************************************************************************************
+! Force soil water content to qsol0 if qsol0>0 and VEGET=F (use bucket
+! instead of ORCHIDEE)
+    if (qsol0>0.) then
+      print*,'WARNING : On impose qsol=',qsol0
+      qsol(:)=qsol0
+    endif
+!****************************************************************************************
+
+!****************************************************************************************
+! 2) Initialization to zero 
+!    Done for all local variables that will be compressed later
+!    and argument with INTENT(OUT)
+!****************************************************************************************
+    cdragh = 0.0  ; cdragm = 0.0     ; dflux_t = 0.0   ; dflux_q = 0.0
+    ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0     ; zu1 = 0.0        
+    zv1 = 0.0     ; yqsurf = 0.0     ; yalb1 = 0.0     ; yalb2 = 0.0    
+    yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0    
+    ysollw = 0.0  ; yrugos = 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         
+    yq = 0.0      ; pctsrf_new = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0 
+    yrugoro = 0.0 ; yu10mx = 0.0     ; yu10my = 0.0    ; ywindsp = 0.0   
+    d_ts = 0.0    ; yfluxlat=0.0     ; flux_t = 0.0    ; flux_q = 0.0     
+    flux_u = 0.0  ; flux_v = 0.0     ; d_t = 0.0       ; d_q = 0.0      
+    d_u = 0.0     ; d_v = 0.0        ; zcoefh = 0.0    ; yqsol = 0.0    
+    ytherm = 0.0  ; ytke=0.
+     
+    ytsoil = 999999. 
+
+!****************************************************************************************
+! 3) - Calculate pressure thickness of each layer
+!    - Calculate the wind at first layer
+!    - Mean calculations of albedo
+!    - Calculate net radiance at sub-surface
+!****************************************************************************************
+    DO k = 1, klev
+       DO i = 1, klon
+          delp(i,k) = paprs(i,k)-paprs(i,k+1)
+       ENDDO
+    ENDDO
+    DO i = 1, klon
+       zx_alf1 = 1.0
+       zx_alf2 = 1.0 - zx_alf1
+       u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2
+       v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2
+    ENDDO
+
+
+!****************************************************************************************
+! Test for rugos........ from physiq.. A la fin plutot???
+!
+!****************************************************************************************
+
+    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)
+       ENDDO
+    ENDDO
+
+! 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
+
+    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
+
+! We here suppose the fraction f1 of incoming radiance of visible radiance 
+! as a fraction of all shortwave radiance 
+!    f1 = 0.5 
+    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
+
+! Calculation of mean temperature at surface grid points
+    ztsol(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+
+! Linear distrubution on sub-surface of long- and shortwave net radiance
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf))
+          solsw(i,nsrf) = solsw_m(i) * (1.-alb(i,nsrf)) / (1.-alb_m(i))
+       ENDDO
+    ENDDO
+
+
+! Downwelling longwave radiation at mean surface
+    lwdown_m(:) = 0.0
+    DO i = 1, klon
+       lwdown_m(i) = sollw_m(i) + RSIGMA*ztsol(i)**4
+    ENDDO
+
+!****************************************************************************************
+! 4) Loop over different surfaces
+!
+! All points with a possibility of the current surface are used. This is done
+! to allow the sea-ice to appear or disappear. It is considered here that the 
+! entier domaine of the ocean possibly can contain sea-ice.
+! 
+!****************************************************************************************
+
+    pctsrf_pot = pctsrf
+    pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+    pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+      
+    loop_nbsrf: DO nsrf = 1, nbsrf
+
+! Search for index(ni) and size(knon) of domaine to treat
+       ni(:) = 0
+       knon  = 0
+       DO i = 1, klon
+          IF (pctsrf_pot(i,nsrf).GT.epsfra) THEN
+             knon = knon + 1
+             ni(knon) = i
+          ENDIF
+       ENDDO
+
+       ! write index, with IOIPSL
+       IF (debugindex .AND. mpi_size==1) THEN 
+          tabindx(:)=0.
+          DO i=1,knon
+             tabindx(i)=FLOAT(i)
+          END DO
+          debugtab(:,:) = 0.
+          ndexbg(:) = 0
+          CALL gath2cpl(tabindx,debugtab,knon,ni)
+          CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1), ndexbg)
+       ENDIF
+       
+!****************************************************************************************
+! 5) Compress variables 
+!
+!****************************************************************************************
+
+       DO j = 1, knon
+          i = ni(j)
+          ypct(j)    = pctsrf(i,nsrf)
+          yts(j)     = ts(i,nsrf)
+          ysnow(j)   = snow(i,nsrf)
+          yqsurf(j)  = qsurf(i,nsrf)
+          yalb(j)    = alb(i,nsrf)
+          yalb1(j)   = alb1(i,nsrf)
+          yalb2(j)   = alb2(i,nsrf)
+          yrain_f(j) = rain_f(i)
+          ysnow_f(j) = snow_f(i)
+          yagesno(j) = agesno(i,nsrf)
+          yfder(j)   = fder(i)
+          ysolsw(j)  = solsw(i,nsrf)
+          ysollw(j)  = sollw(i,nsrf)
+          yrugos(j)  = rugos(i,nsrf)
+          yrugoro(j) = rugoro(i)
+          yu1(j)     = u1lay(i)
+          yv1(j)     = v1lay(i)
+          ypaprs(j,klev+1) = paprs(i,klev+1)
+          yu10mx(j) = u10m(i,nsrf)
+          yu10my(j) = v10m(i,nsrf)
+          ywindsp(j) = SQRT(yu10mx(j)*yu10mx(j) + yu10my(j)*yu10my(j) )
+       END DO
+
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ypaprs(j,k) = paprs(i,k)
+             ypplay(j,k) = pplay(i,k)
+             ydelp(j,k) = delp(i,k)
+             ytke(j,k)=tke(i,k,nsrf)
+             yu(j,k) = u(i,k)
+             yv(j,k) = v(i,k)
+             yt(j,k) = t(i,k)
+             yq(j,k) = q(i,k)
+          ENDDO
+       ENDDO
+       
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ytsoil(j,k) = ftsoil(i,k,nsrf)
+          END DO
+       END DO
+       
+       ! qsol(water height in soil) only for bucket continental model
+       IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             yqsol(j) = qsol(i)
+          END DO
+       ENDIF
+       
+!****************************************************************************************
+! 6) Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+!    atmosphere and coefficients for turbulent diffusion at surface(Cdrag).
+!
+!****************************************************************************************
+
+       CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
+            ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf,  &
+            ycoefm, ycoefh,ytke)
+       
+!****************************************************************************************
+! 
+! 8) "La descente" - "The downhill"
+!  
+!  climb_hq_down and climb_wind_down calculate the coefficients
+!  Ccoef_X et Dcoef_X for X=[H, Q, U, V].
+!  Only the coefficients at surface for H and Q are returned.
+!
+!****************************************************************************************
+
+! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q 
+       CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, &
+            ydelp, yt, yq, dtime, &
+            petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V
+       CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv)
+      
+
+!****************************************************************************************
+! 9) Small calculations
+!
+!****************************************************************************************
+
+! - Reference pressure is given the values at surface level          
+       ypsref(:) = ypaprs(:,1)  
+
+! - Constant CO2 is copied to global grid
+       r_co2_ppm(:) = co2_ppm
+
+!****************************************************************************************
+!
+! 10) Switch selon current surface
+!     It is necessary to start with the continental surfaces because the ocean
+!     needs their run-off.
+!
+!****************************************************************************************
+       SELECT CASE(nsrf)
+     
+       CASE(is_ter)
+          ! ylwdown : to be removed, calculation is now done at land surface in surf_land
+          ylwdown(:)=0.0
+          DO i=1,knon
+             ylwdown(i)=lwdown_m(ni(i))
+          END DO
+          CALL surf_land(itap, dtime, date0, jour, knon, ni,&
+               rlon, rlat, &
+               debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, & 
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ysnow, yqsol, yagesno, ytsoil, &
+               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
+               yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, pctsrf_nsrf, &
+               ylwdown)
+     
+       CASE(is_lic)
+          CALL surf_landice(itap, dtime, knon, ni, &
+               ysolsw, ysollw, yts, ypplay(:,1), &
+               ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               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, pctsrf_nsrf)
+          
+       CASE(is_oce)
+          CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, &
+               yrugos, ywindsp, rmu0, yfder, &
+               itap, dtime, jour, knon, ni, &
+               debut, &
+               ypplay(:,1), ycoefh(:,1), ycoefm(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ysnow, yqsurf, yagesno, &
+               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+       CASE(is_sic)
+          CALL surf_seaice( &
+               rlon, rlat, ysolsw, ysollw, yalb1, yfder, &
+               itap, dtime, jour, knon, ni, &
+               debut, lafin, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               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, pctsrf_nsrf)
+          
+
+       CASE DEFAULT
+          WRITE(lunout,*) 'Surface index = ', nsrf
+          abort_message = 'Surface index not valid'
+          CALL abort_gcm(modname,abort_message,1)
+       END SELECT
+
+!****************************************************************************************
+! Save the fraction of this sub-surface 
+!
+!****************************************************************************************
+       pctsrf_new(:,nsrf) = pctsrf_nsrf(:)
+
+!****************************************************************************************
+! 11) - Calcul the increment of surface temperature
+!
+!****************************************************************************************
+       y_d_ts(1:knon)   = ytsurf_new(1:knon) - yts(1:knon)
+ 
+!****************************************************************************************
+!
+! 12) "La remontee" - "The uphill"
+!
+!  The fluxes (y_flux_X) and tendancy (y_d_X) are calculated 
+!  for X=H, Q, U and V, for all vertical levels.
+!
+!****************************************************************************************
+! H and Q
+!      print *,'pbl_surface: ok_flux_surf=',ok_flux_surf
+!      print *,'pbl_surface: fsens flat RLVTT=',fsens,flat,RLVTT
+       if (ok_flux_surf) then
+          y_flux_t1(:) =  fsens
+          y_flux_q1(:) =  flat/RLVTT
+          yfluxlat(:) =  flat
+       else
+          y_flux_t1(:) =  yfluxsens(:)
+          y_flux_q1(:) = -yevap(:)
+       endif
+
+       CALL climb_hq_up(knon, dtime, yt, yq, &
+            y_flux_q1, y_flux_t1, ypaprs, ypplay, &
+            y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:))    
+       
+! U and V
+       CALL climb_wind_up(knon, dtime, yu, yv, &
+            y_flux_u, y_flux_v, y_d_u, y_d_v)
+
+       DO j = 1, knon
+          y_dflux_t(j) = y_dflux_t(j) * ypct(j)
+          y_dflux_q(j) = y_dflux_q(j) * ypct(j)
+          yu1(j) = yu1(j) *  ypct(j)
+          yv1(j) = yv1(j) *  ypct(j)
+       ENDDO
+
+!****************************************************************************************
+! 13) Transform variables for output format : 
+!     - Decompress
+!     - Multiply with pourcentage of current surface
+!     - Cumulate in global variable
+!
+!****************************************************************************************
+
+       tke(:,:,nsrf)=0.
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ycoefh(j,k) = ycoefh(j,k) * ypct(j)
+             ycoefm(j,k) = ycoefm(j,k) * ypct(j)
+             y_d_t(j,k) = y_d_t(j,k) * ypct(j)
+             y_d_q(j,k) = y_d_q(j,k) * ypct(j)
+             y_d_u(j,k) = y_d_u(j,k) * ypct(j)
+             y_d_v(j,k) = y_d_v(j,k) * ypct(j)
+
+             flux_t(i,k,nsrf) = y_flux_t(j,k)
+             flux_q(i,k,nsrf) = y_flux_q(j,k)
+             flux_u(i,k,nsrf) = y_flux_u(j,k)
+             flux_v(i,k,nsrf) = y_flux_v(j,k)
+
+             tke(i,k,nsrf)=ytke(j,k)
+
+          ENDDO
+       ENDDO
+       
+       evap(:,nsrf) = - flux_q(:,1,nsrf)
+       
+       alb1(:, nsrf) = 0.
+       alb2(:, nsrf) = 0.
+       snow(:, nsrf) = 0.
+       qsurf(:, nsrf) = 0.
+       rugos(:, nsrf) = 0.
+       fluxlat(:,nsrf) = 0.
+       DO j = 1, knon
+          i = ni(j)
+          d_ts(i,nsrf) = y_d_ts(j)
+          alb1(i,nsrf) = yalb1_new(j)  
+          alb2(i,nsrf) = yalb2_new(j)
+          snow(i,nsrf) = ysnow(j)  
+          qsurf(i,nsrf) = yqsurf(j)
+          rugos(i,nsrf) = yz0_new(j)
+          fluxlat(i,nsrf) = yfluxlat(j)
+          agesno(i,nsrf) = yagesno(j)  
+          cdragh(i) = cdragh(i) + ycoefh(j,1)
+          cdragm(i) = cdragm(i) + ycoefm(j,1)
+          dflux_t(i) = dflux_t(i) + y_dflux_t(j)
+          dflux_q(i) = dflux_q(i) + y_dflux_q(j)
+          zu1(i) = zu1(i) + yu1(j)
+          zv1(i) = zv1(i) + yv1(j)
+       END DO
+
+       IF ( nsrf .EQ. is_ter ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             qsol(i) = yqsol(j)
+          END DO
+       END IF
+       
+       ftsoil(:,:,nsrf) = 0.
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ftsoil(i, k, nsrf) = ytsoil(j,k)
+          END DO
+       END DO
+       
+       
+#ifdef CRAY
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+#else
+       DO j = 1, knon
+          i = ni(j)
+          DO k = 1, klev
+#endif
+             d_t(i,k) = d_t(i,k) + y_d_t(j,k)
+             d_q(i,k) = d_q(i,k) + y_d_q(j,k)
+             d_u(i,k) = d_u(i,k) + y_d_u(j,k)
+             d_v(i,k) = d_v(i,k) + y_d_v(j,k)
+             zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)
+#ifdef CRAY
+          END DO
+       END DO
+#else
+          END DO
+       END DO
+#endif
+
+!****************************************************************************************
+! 14) Calculate the temperature et relative humidity at 2m and the wind at 10m 
+!     Call HBTM
+!
+!****************************************************************************************
+       t2m(:,nsrf)    = 0.
+       q2m(:,nsrf)    = 0.
+       u10m(:,nsrf)   = 0.
+       v10m(:,nsrf)   = 0.
+
+       pblh(:,nsrf)   = 0.        ! Hauteur de couche limite
+       plcl(:,nsrf)   = 0.        ! Niveau de condensation de la CLA
+       capCL(:,nsrf)  = 0.        ! CAPE de couche limite
+       oliqCL(:,nsrf) = 0.        ! eau_liqu integree de couche limite
+       cteiCL(:,nsrf) = 0.        ! cloud top instab. crit. couche limite
+       pblt(:,nsrf)   = 0.        ! T a la Hauteur de couche limite
+       therm(:,nsrf)  = 0.
+       trmb1(:,nsrf)  = 0.        ! deep_cape
+       trmb2(:,nsrf)  = 0.        ! inhibition 
+       trmb3(:,nsrf)  = 0.        ! Point Omega
+
+#undef T2m     
+#define T2m     
+#ifdef T2m
+! diagnostic t,q a 2m et u, v a 10m
+
+       DO j=1, knon
+          i = ni(j)
+          uzon(j) = yu(j,1) + y_d_u(j,1)
+          vmer(j) = yv(j,1) + y_d_v(j,1)
+          tair1(j) = yt(j,1) + y_d_t(j,1)
+          qair1(j) = yq(j,1) + y_d_q(j,1)
+          zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
+               * (ypaprs(j,1)-ypplay(j,1))
+          tairsol(j) = yts(j) + y_d_ts(j)
+          rugo1(j) = yrugos(j)
+          IF(nsrf.EQ.is_oce) THEN
+             rugo1(j) = rugos(i,nsrf)
+          ENDIF
+          psfce(j)=ypaprs(j,1)
+          patm(j)=ypplay(j,1)
+          qairsol(j) = yqsurf(j)
+       END DO
+       
+
+! Calculate the temperature et relative humidity at 2m and the wind at 10m 
+       CALL stdlevvar(klon, knon, nsrf, zxli, &
+            uzon, vmer, tair1, qair1, zgeo1, &
+            tairsol, qairsol, rugo1, psfce, patm, &
+            yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
+
+       DO j=1, knon
+          i = ni(j)
+          t2m(i,nsrf)=yt2m(j)
+          
+          q2m(i,nsrf)=yq2m(j)
+
+! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
+          u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2)
+          v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2)
+
+       END DO
+
+
+       CALL HBTM(knon, ypaprs, ypplay, &
+            yt2m,yt10m,yq2m,yq10m,yustar, &
+            y_flux_t,y_flux_q,yu,yv,yt,yq, &
+            ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, &
+            ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl)
+       
+       DO j=1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = ypblh(j)
+          plcl(i,nsrf)   = ylcl(j)
+          capCL(i,nsrf)  = ycapCL(j)
+          oliqCL(i,nsrf) = yoliqCL(j)
+          cteiCL(i,nsrf) = ycteiCL(j)
+          pblT(i,nsrf)   = ypblT(j)
+          therm(i,nsrf)  = ytherm(j)
+          trmb1(i,nsrf)  = ytrmb1(j)
+          trmb2(i,nsrf)  = ytrmb2(j)
+          trmb3(i,nsrf)  = ytrmb3(j)
+       END DO
+       
+#else 
+! not defined T2m
+! No calculation
+! Set output variables to zero
+       DO j = 1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = 0.
+          plcl(i,nsrf)   = 0.
+          capCL(i,nsrf)  = 0.
+          oliqCL(i,nsrf) = 0.
+          cteiCL(i,nsrf) = 0.
+          pblT(i,nsrf)   = 0.
+          therm(i,nsrf)  = 0.
+          trmb1(i,nsrf)  = 0.
+          trmb2(i,nsrf)  = 0.
+          trmb3(i,nsrf)  = 0.
+       END DO
+       DO j = 1, knon
+          i = ni(j) 
+          t2m(i,nsrf)=0.
+          q2m(i,nsrf)=0.
+          u10m(i,nsrf)=0.
+          v10m(i,nsrf)=0.
+       END DO
+#endif
+
+!****************************************************************************************
+! 15) End of loop over different surfaces
+!
+!****************************************************************************************
+    END DO loop_nbsrf
+
+!****************************************************************************************
+! 16) Calculate the mean value over all sub-surfaces for som variables
+!
+!     NB!!! jg : Pour garder la convergence numerique j'utilise pctsrf_new comme c'etait 
+!     fait dans physiq.F mais ca devrait plutot etre pctsrf???!!!!! A verifier!
+!****************************************************************************************
+    
+    zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
+    zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO k = 1, klev
+          DO i = 1, klon
+             zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf_new(i,nsrf)
+          END DO
+       END DO
+    END DO
+
+    DO i = 1, klon
+       zxsens(i)     = - zxfluxt(i,1) ! flux de chaleur sensible au sol
+       zxevap(i)     = - zxfluxq(i,1) ! flux d'evaporation au sol
+       fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i)
+    ENDDO
+   
+
+    DO i = 1, klon
+       IF ( ABS( pctsrf_new(i, is_ter) + pctsrf_new(i, is_lic) + &
+            pctsrf_new(i, is_oce) + pctsrf_new(i, is_sic)  - 1.) .GT. EPSFRA) & 
+            THEN 
+          WRITE(*,*) 'physiq : pb sous surface au point ', i, &
+               pctsrf_new(i, 1 : nbsrf)
+       ENDIF
+    ENDDO
+
+!
+! Incrementer la temperature du sol
+!
+    zxtsol(:) = 0.0  ; zxfluxlat(:) = 0.0
+    zt2m(:) = 0.0    ; zq2m(:) = 0.0 
+    zu10m(:) = 0.0   ; zv10m(:) = 0.0
+    s_pblh(:) = 0.0  ; s_plcl(:) = 0.0 
+    s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0
+    s_cteiCL(:) = 0.0; s_pblT(:) = 0.0
+    s_therm(:) = 0.0 ; s_trmb1(:) = 0.0
+    s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0
+    
+    
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon          
+          ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf)
+          
+          wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) &
+               + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf_new(i,nsrf)
+          wfbilo(i,nsrf) = (evap(i,nsrf) - (rain_f(i) + snow_f(i))) * &
+               pctsrf_new(i,nsrf)
+
+          zxtsol(i)    = zxtsol(i)    + ts(i,nsrf)      * pctsrf_new(i,nsrf)
+          zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf_new(i,nsrf)
+          
+          zt2m(i)  = zt2m(i)  + t2m(i,nsrf)  * pctsrf_new(i,nsrf)
+          zq2m(i)  = zq2m(i)  + q2m(i,nsrf)  * pctsrf_new(i,nsrf)
+          zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf_new(i,nsrf)
+          zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf_new(i,nsrf)
+
+          s_pblh(i)   = s_pblh(i)   + pblh(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_plcl(i)   = s_plcl(i)   + plcl(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_capCL(i)  = s_capCL(i)  + capCL(i,nsrf) * pctsrf_new(i,nsrf)
+          s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf_new(i,nsrf)
+          s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf_new(i,nsrf)
+          s_pblT(i)   = s_pblT(i)   + pblT(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_therm(i)  = s_therm(i)  + therm(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb1(i)  = s_trmb1(i)  + trmb1(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb2(i)  = s_trmb2(i)  + trmb2(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb3(i)  = s_trmb3(i)  + trmb3(i,nsrf) * pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+    IF (check) THEN
+       amn=MIN(ts(1,is_ter),1000.)
+       amx=MAX(ts(1,is_ter),-1000.)
+       DO i=2, klon
+          amn=MIN(ts(i,is_ter),amn)
+          amx=MAX(ts(i,is_ter),amx)
+       ENDDO
+       PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx
+    ENDIF
+!
+! If a sub-surface does not exsist for a grid point, the mean value for all 
+! sub-surfaces is distributed.
+!
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN
+             ts(i,nsrf)     = zxtsol(i)
+             t2m(i,nsrf)    = zt2m(i)
+             q2m(i,nsrf)    = zq2m(i)
+             u10m(i,nsrf)   = zu10m(i)
+             v10m(i,nsrf)   = zv10m(i)
+
+! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour
+             pblh(i,nsrf)   = s_pblh(i)
+             plcl(i,nsrf)   = s_plcl(i)
+             capCL(i,nsrf)  = s_capCL(i)
+             oliqCL(i,nsrf) = s_oliqCL(i) 
+             cteiCL(i,nsrf) = s_cteiCL(i)
+             pblT(i,nsrf)   = s_pblT(i)
+             therm(i,nsrf)  = s_therm(i)
+             trmb1(i,nsrf)  = s_trmb1(i)
+             trmb2(i,nsrf)  = s_trmb2(i)
+             trmb3(i,nsrf)  = s_trmb3(i)
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+    DO i = 1, klon
+       fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 
+    ENDDO
+    
+    zxqsurf(:) = 0.0
+    zxsnow(:)  = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf_new(i,nsrf)
+          zxsnow(i)  = zxsnow(i)  + snow(i,nsrf)  * pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+!
+!IM Calculer l'humidite relative a 2m (rh2m) pour diagnostique
+!IM ajout dependance type surface
+    rh2m(:)   = 0.0
+    qsat2m(:) = 0.0
+
+    DO i = 1, klon
+       DO nsrf=1, nbsrf
+          zx_t1(i,nsrf) = t2m(i,nsrf)
+          IF (thermcep) THEN
+             zdelta1(i,nsrf) = MAX(0.,SIGN(1.,rtt-zx_t1(i,nsrf)))
+             zx_qs1(i,nsrf)  = r2es * &
+                  FOEEW(zx_t1(i,nsrf),zdelta1(i,nsrf))/paprs(i,1)
+             zx_qs1(i,nsrf)  = MIN(0.5,zx_qs1(i,nsrf))
+             zcor1(i,nsrf)   = 1./(1.-retv*zx_qs1(i,nsrf))
+             zx_qs1(i,nsrf)  = zx_qs1(i,nsrf)*zcor1(i,nsrf)
+          END IF
+          zx_rh2m(i,nsrf) = q2m(i,nsrf)/zx_qs1(i,nsrf)
+          zx_qsat2m(i,nsrf)=zx_qs1(i,nsrf)
+          rh2m(i) = rh2m(i)+zx_rh2m(i,nsrf)*pctsrf_new(i,nsrf)
+          qsat2m(i)=qsat2m(i)+zx_qsat2m(i,nsrf)*pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+! 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
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, &
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! 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
+
+ 
+!****************************************************************************************
+! Return module variables for writing to restart file
+!
+!****************************************************************************************    
+    qsol_rst(:)       = qsol(:)
+    fder_rst(:)       = fder(:)
+    snow_rst(:,:)     = snow(:,:)
+    qsurf_rst(:,:)    = qsurf(:,:)
+    evap_rst(:,:)     = evap(:,:)
+    rugos_rst(:,:)    = rugos(:,:)
+    agesno_rst(:,:)   = agesno(:,:)
+    ftsoil_rst(:,:,:) = ftsoil(:,:,:)
+
+!****************************************************************************************
+! Deallocate module variables
+!
+!****************************************************************************************
+    DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
+
+  END SUBROUTINE pbl_surface_final
+!  
+!****************************************************************************************
+!  
+
+END MODULE pbl_surface_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phyetat0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phyetat0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phyetat0.F	(revision 984)
@@ -0,0 +1,1835 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phyetat0 (fichnom,
+     .           ocean_in, ok_veget_in,
+     .           clesphy0,
+     .           tabcntr0)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE ocean_slab_mod,   ONLY : ocean_slab_init
+      USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+      USE ocean_forced_mod, ONLY : ocean_forced_init
+      USE fonte_neige_mod,  ONLY : fonte_neige_init
+      USE pbl_surface_mod,  ONLY : pbl_surface_init
+      USE surface_data,     ONLY : ocean, ok_veget
+      USE phys_state_var_mod
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Lecture de l'etat initial pour la physique
+c======================================================================
+#include "dimensions.h"
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+
+c les variables globales lues dans le fichier restart
+      REAL rlat_glo(klon_glo), rlon_glo(klon_glo)
+      REAL pctsrf_glo(klon_glo, nbsrf)
+      REAL tsol_glo(klon_glo,nbsrf)
+      REAL alb1_glo(klon_glo,nbsrf)
+      REAL alb2_glo(klon_glo,nbsrf)
+      REAL rain_fall_glo(klon_glo)
+      REAL snow_fall_glo(klon_glo)
+      real solsw_glo(klon_glo)
+      real sollw_glo(klon_glo)
+      REAL radsol_glo(klon_glo)
+      REAL zmea_glo(klon_glo)
+      REAL zstd_glo(klon_glo)
+      REAL zsig_glo(klon_glo)
+      REAL zgam_glo(klon_glo)
+      REAL zthe_glo(klon_glo)
+      REAL zpic_glo(klon_glo)
+      REAL zval_glo(klon_glo)
+      REAL rugsrel_glo(klon_glo)
+      REAL t_ancien_glo(klon_glo,klev), q_ancien_glo(klon_glo,klev)
+      REAL clwcon_glo(klon_glo,klev)
+      REAL rnebcon_glo(klon_glo,klev) 
+      REAL ratqs_glo(klon_glo,klev)
+      REAL pbl_tke_glo(klon_glo,klev+1,nbsrf)
+      REAL zmax0_glo(klon_glo), f0_glo(klon)
+      REAL ema_work1_glo(klon_glo, klev), ema_work2_glo(klon_glo, klev)
+      REAL wake_deltat_glo(klon_glo,klev)
+      REAL wake_deltaq_glo(klon_glo,klev)
+      REAL wake_s_glo(klon_glo), wake_cstar_glo(klon_glo)
+      REAL wake_fip_glo(klon_glo)
+      REAL tsoil_p(klon,nsoilmx,nbsrf)
+      REAL tslab_p(klon), seaice_p(klon)
+      REAL qsurf_p(klon,nbsrf)
+      REAL qsol_p(klon)
+      REAL snow_p(klon,nbsrf)
+      REAL evap_p(klon,nbsrf)
+      real fder_p(klon)
+      REAL frugs_p(klon,nbsrf)
+      REAL agesno_p(klon,nbsrf)
+      REAL run_off_lic_0_p(klon)
+      
+      LOGICAL,SAVE ::  ancien_ok_glo
+!$OMP THREADPRIVATE(ancien_ok_glo)  
+    
+      REAL zmasq_glo(klon_glo)
+      REAL tsoil(klon_glo,nsoilmx,nbsrf)
+cIM "slab" ocean
+      REAL tslab(klon_glo), seaice(klon_glo)
+      REAL qsurf(klon_glo,nbsrf)
+      REAL qsol(klon_glo)
+      REAL snow(klon_glo,nbsrf)
+      REAL evap(klon_glo,nbsrf)
+      real fder(klon_glo)
+      REAL frugs(klon_glo,nbsrf)
+      REAL agesno(klon_glo,nbsrf)
+      REAL fractint(klon_glo)
+      REAL run_off_lic_0(klon_glo)
+
+      CHARACTER*6 ocean_in
+      LOGICAL ok_veget_in
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+c
+      REAL xmin, xmax
+c
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil ,k
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length), tabcntr0(length)
+      REAL,SAVE :: tab_cntrl_omp(length)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+
+c FH1D
+c     real iolat(jjm+1)
+      real iolat(jjm+1-1/iim)
+c
+c Ouvrir le fichier contenant l'etat initial:
+c
+
+c$OMP MASTER
+      print *,'MASTER -x , omp_rank=',omp_rank
+c$OMP END MASTER
+
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+        print*,'fichnom ',fichnom
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Pb d''ouverture du fichier '//fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+      ENDIF
+c$OMP END MASTER
+c
+c Lecture des parametres de controle:
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <controle> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <controle>'
+         CALL abort
+      ENDIF
+      ENDIF
+
+c$OMP END MASTER
+       
+       CALL bcast(tab_cntrl)
+       
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Les constantes de la physiques sont lues dans la physique seulement.
+! Les egalites du type
+!             tab_cntrl( 5 )=clesphy0(1)
+! sont remplacees par
+!             clesphy0(1)=tab_cntrl( 5 )
+! On inverse aussi la logique.
+! On remplit les tab_cntrl avec les parametres lus dans les .def
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         DO i = 1, length
+           tabcntr0( i ) = tab_cntrl( i )
+         ENDDO
+c
+         tab_cntrl(1)=dtime
+         tab_cntrl(2)=radpas
+         co2_ppm_etat0      = tab_cntrl(3)
+         solaire_etat0      = tab_cntrl(4)
+         tab_cntrl(5)=iflag_con
+         tab_cntrl(6)=nbapp_rad
+
+         if (cycle_diurne) tab_cntrl( 7) =1.
+         if (soil_model) tab_cntrl( 8) =1.
+         if (new_oliq) tab_cntrl( 9) =1.
+         if (ok_orodr) tab_cntrl(10) =1.
+         if (ok_orolf) tab_cntrl(11) =1.
+         if (ok_limitvrai) tab_cntrl(12) =1.
+
+
+      itau_phy = tab_cntrl(15)
+
+       
+
+         IF( clesphy0(1).NE.tab_cntrl( 5 ) )  THEN
+             clesphy0(1)=tab_cntrl( 5 )
+         ENDIF
+
+         IF( clesphy0(2).NE.tab_cntrl( 6 ) )  THEN
+             clesphy0(2)=tab_cntrl( 6 )
+         ENDIF
+
+         IF( clesphy0(3).NE.tab_cntrl( 7 ) )  THEN
+             clesphy0(3)=tab_cntrl( 7 )
+         ENDIF
+
+         IF( clesphy0(4).NE.tab_cntrl( 8 ) )  THEN
+             clesphy0(4)=tab_cntrl( 8 )
+         ENDIF
+
+         IF( clesphy0(5).NE.tab_cntrl( 9 ) )  THEN
+             clesphy0(5)=tab_cntrl( 9 )
+         ENDIF
+
+         IF( clesphy0(6).NE.tab_cntrl( 10 ) )  THEN
+             clesphy0(6)=tab_cntrl( 10 )
+         ENDIF
+
+         IF( clesphy0(7).NE.tab_cntrl( 11 ) )  THEN
+             clesphy0(7)=tab_cntrl( 11 )
+         ENDIF
+
+         IF( clesphy0(8).NE.tab_cntrl( 12 ) )  THEN
+             clesphy0(8)=tab_cntrl( 12 )
+         ENDIF
+
+
+c
+c Lecture des latitudes (coordonnees):
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <latitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlat_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <longitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlon_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+C
+C
+C Lecture du masque terre mer
+C
+
+      ierr = NF_INQ_VARID (nid, "masque", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmasq_glo)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, zmasq_glo)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <masque>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <masque> est absent'
+          PRINT*, 'fichier startphy non compatible avec phyetat0'
+C      CALL abort
+      ENDIF
+
+       
+C Lecture des fractions pour chaque sous-surface
+C
+C initialisation des sous-surfaces
+C
+      pctsrf = 0.
+C
+C fraction de terre
+C
+
+      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid,        
+     .                             pctsrf_glo(1 : klon_glo,is_ter))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf_glo(1 : klon_glo,is_ter))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FTER>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FTER> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C fraction de glace de terre
+C
+      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf_glo(1 : klon_glo,is_lic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf_glo(1 : klon_glo,is_lic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FLIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+c@$$         CALL abort
+      ENDIF
+C
+C fraction d'ocean
+C
+      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf_glo(1 : klon_glo,is_oce))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf_glo(1 : klon_glo,is_oce))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FOCE>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C fraction glace de mer
+C
+      ierr = NF_INQ_VARID (nid, "FSIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf_glo(1 : klon_glo,is_sic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf_glo(1 : klon_glo, is_sic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FSIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C  Verification de l'adequation entre le masque et les sous-surfaces
+C
+      fractint( 1 : klon_glo) = pctsrf_glo(1 : klon_glo, is_ter) 
+     $    + pctsrf_glo(1 : klon_glo, is_lic)
+      DO i = 1 , klon_glo
+        IF ( abs(fractint(i) - zmasq_glo(i) ) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0: attention fraction terre pas ', 
+     $          'coherente ', i, zmasq_glo(i), pctsrf_glo(i, is_ter)
+     $          ,pctsrf_glo(i, is_lic)
+        ENDIF 
+      END DO 
+      fractint (1 : klon_glo) =  pctsrf_glo(1 : klon_glo, is_oce) 
+     $    + pctsrf_glo(1 : klon_glo, is_sic)
+      DO i = 1 , klon_glo
+        IF ( abs( fractint(i) - (1. - zmasq_glo(i))) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0 attention fraction ocean pas ', 
+     $          'coherente ', i, zmasq_glo(i) , pctsrf_glo(i, is_oce)
+     $          ,pctsrf_glo(i, is_sic)
+        ENDIF 
+      END DO 
+
+C
+c Lecture des temperatures du sol:
+c
+
+      ierr = NF_INQ_VARID (nid, "TS", nvarid)
+      IF (ierr.NE.NF_NOERR) 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"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "TS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <TS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol_glo(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, tsol_glo(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <TS"//str2//">"
+             CALL abort
+           ENDIF
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              xmin = MIN(tsol_glo(i,nsrf),xmin)
+              xmax = MAX(tsol_glo(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <TS> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol_glo(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsol_glo(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(tsol_glo(i,1),xmin)
+            xmax = MAX(tsol_glo(i,1),xmax)
+         ENDDO
+         PRINT*,'Temperature du sol <TS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            tsol_glo(i,nsrf) = tsol_glo(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture des temperatures du sol profond:
+c
+      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
+      ENDIF
+      WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+      ierr = NF_INQ_VARID (nid, 'Tsoil'//str7, nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+         PRINT*, "          Il prend donc la valeur de surface"
+         DO i=1, klon_glo
+             tsoil(i,isoil,nsrf)=tsol_glo(i,nsrf)
+         ENDDO
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil,nsrf))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil,nsrf))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "Lecture echouee pour <Tsoil"//str7//">"
+            CALL abort
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cIM "slab" ocean 
+c
+c Lecture de tslab (pour slab ocean seulement):      
+c
+      IF (ocean_in .eq. 'slab  ') then
+        ierr = NF_INQ_VARID (nid, "TSLAB", nvarid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Le champ <TSLAB> est absent"
+          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tslab)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, tslab)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Lecture echouee pour <TSLAB>"
+          CALL abort
+        ENDIF
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO i = 1, klon_glo
+          xmin = MIN(tslab(i),xmin)
+          xmax = MAX(tslab(i),xmax)
+        ENDDO
+        PRINT*,'Min, Max tslab (utilise si OCEAN=slab )', xmin, xmax
+c
+c Lecture de seaice (pour slab ocean seulement):
+c
+        ierr = NF_INQ_VARID (nid, "SEAICE", nvarid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Le champ <SEAICE> est absent"
+          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, seaice)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, seaice)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Lecture echouee pour <SEAICE>"
+          CALL abort
+        ENDIF
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO i = 1, klon_glo
+          xmin = MIN(seaice(i),xmin)
+          xmax = MAX(seaice(i),xmax)
+        ENDDO
+        PRINT*,'Masse de la glace de mer (utilise si OCEAN=slab)', 
+     $  xmin, xmax
+      ELSE
+        tslab = 0.
+        seaice = 0.
+      ENDIF
+c
+c Lecture de l'humidite de l'air juste au dessus du sol:
+c
+      ierr = NF_INQ_VARID (nid, "QS", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "QS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <QS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <QS"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            qsurf(i,nsrf) = qsurf(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+C
+C Eau dans le sol (pour le modele de sol "bucket")
+C
+      ierr = NF_INQ_VARID (nid, "QSOL", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, qsol)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <QSOL>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <QSOL> est absent'
+          PRINT*, '          Valeur par defaut nulle'
+          qsol(:)=0.
+c@$$         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+        xmin = MIN(qsol(i),xmin)
+        xmax = MAX(qsol(i),xmax)
+      ENDDO
+      PRINT*,'Eau dans le sol (mm) <QSOL>', xmin, xmax
+c
+c Lecture de neige au sol:
+c
+      ierr = NF_INQ_VARID (nid, "SNOW", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "SNOW"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <SNOW"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <SNOW"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <SNOW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            snow(i,nsrf) = snow(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de albedo de l'interval visible au sol:
+c
+      ierr = NF_INQ_VARID (nid, "ALBE", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "ALBE"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <ALBE"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb1_glo(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, alb1_glo(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <ALBE"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              xmin = MIN(alb1_glo(i,nsrf),xmin)
+              xmax = MAX(alb1_glo(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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb1_glo(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, alb1_glo(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBE>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(alb1_glo(i,1),xmin)
+            xmax = MAX(alb1_glo(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBE>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            alb1_glo(i,nsrf) = alb1_glo(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de albedo au sol dans l'interval proche infra-rouge:
+c
+      ierr = NF_INQ_VARID (nid, "ALBLW", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
+c        PRINT*, '          Mais je vais essayer de lire ALBLW**'
+         PRINT*, '          Mais je vais prendre ALBE**'
+         DO nsrf = 1, nbsrf
+           DO i = 1, klon_glo
+             alb2_glo(i,nsrf) = alb1_glo(i,nsrf)
+           ENDDO
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBLW> est present'
+         PRINT*, '          J ignore donc les autres ALBLW**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alb2_glo(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, alb2_glo(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBLW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(alb2_glo(i,1),xmin)
+            xmax = MAX(alb2_glo(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBLW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            alb2_glo(i,nsrf) = alb2_glo(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de evaporation:  
+c
+      ierr = NF_INQ_VARID (nid, "EVAP", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "EVAP"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <EVAP"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <EVAP"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <EVAP>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            evap(i,nsrf) = evap(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture precipitation liquide:
+c
+      ierr = NF_INQ_VARID (nid, "rain_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <rain_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rain_fall_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rain_fall_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <rain_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(rain_fall_glo(i),xmin)
+         xmax = MAX(rain_fall_glo(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation liquide rain_f:', xmin, xmax
+c
+c Lecture precipitation solide:
+c
+      ierr = NF_INQ_VARID (nid, "snow_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <snow_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow_fall_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, snow_fall_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <snow_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(snow_fall_glo(i),xmin)
+         xmax = MAX(snow_fall_glo(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation solide snow_f:', xmin, xmax
+c
+c Lecture rayonnement solaire au sol:
+c
+      ierr = NF_INQ_VARID (nid, "solsw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <solsw> est absent'
+         PRINT*, 'mis a zero'
+         solsw_glo = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw_glo)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, solsw_glo)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <solsw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(solsw_glo(i),xmin)
+         xmax = MAX(solsw_glo(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
+c
+c Lecture rayonnement IF au sol:
+c
+      ierr = NF_INQ_VARID (nid, "sollw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <sollw> est absent'
+         PRINT*, 'mis a zero'
+         sollw_glo = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw_glo)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, sollw_glo)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <sollw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(sollw_glo(i),xmin)
+         xmax = MAX(sollw_glo(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
+      
+      ENDIF  ! is_mpi_root
+c$OMP END MASTER
+
+
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+c
+c Lecture derive des flux:
+c
+      ierr = NF_INQ_VARID (nid, "fder", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <fder> est absent'
+         PRINT*, 'mis a zero'
+         fder = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, fder)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <fder>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(fder(i),xmin)
+         xmax = MAX(fder(i),xmax)
+      ENDDO
+      PRINT*,'Derive des flux fder:', xmin, xmax
+
+c
+c Lecture du rayonnement net au sol:
+c
+      ierr = NF_INQ_VARID (nid, "RADS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RADS> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, radsol_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RADS>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(radsol_glo(i),xmin)
+         xmax = MAX(radsol_glo(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
+c
+c Lecture de la longueur de rugosite 
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUG", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "RUG"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <RUG"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <RUG"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUG>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            frugs(i,nsrf) = frugs(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de l'age de la neige:
+c
+      ierr = NF_INQ_VARID (nid, "AGESNO", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "AGESNO"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
+              agesno = 50.0
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <AGESNO"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <AGESNO>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            agesno(i,nsrf) = agesno(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "ZMEA", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZMEA> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zmea_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZMEA>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zmea_glo(i),xmin)
+         xmax = MAX(zmea_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSTD", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSTD> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zstd_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSTD>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zstd_glo(i),xmin)
+         xmax = MAX(zstd_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSIG", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSIG> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zsig_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSIG>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zsig_glo(i),xmin)
+         xmax = MAX(zsig_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZGAM", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZGAM> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zgam_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZGAM>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zgam_glo(i),xmin)
+         xmax = MAX(zgam_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZTHE", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZTHE> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zthe_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZTHE>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zthe_glo(i),xmin)
+         xmax = MAX(zthe_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZPIC", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZPIC> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zpic_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZPIC>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zpic_glo(i),xmin)
+         xmax = MAX(zpic_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
+c
+      ierr = NF_INQ_VARID (nid, "ZVAL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZVAL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zval_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZVAL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zval_glo(i),xmin)
+         xmax = MAX(zval_glo(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUGSREL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RUGSREL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugsrel_glo)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rugsrel_glo)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RUGSREL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(rugsrel_glo(i),xmin)
+         xmax = MAX(rugsrel_glo(i),xmax)
+      ENDDO
+      PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
+c
+c
+      ancien_ok_glo = .TRUE.
+c
+      ierr = NF_INQ_VARID (nid, "TANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok_glo = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, t_ancien_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, t_ancien_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok_glo = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      clwcon_glo=0.
+      ierr = NF_INQ_VARID (nid, "CLWCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ CLWCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+c        clwcon_glo = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, clwcon_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, clwcon_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <CLWCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon_glo)
+      xmax = MAXval(clwcon_glo)
+      PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
+c
+      rnebcon_glo = 0.
+      ierr = NF_INQ_VARID (nid, "RNEBCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ RNEBCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+c        rnebcon_glo = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rnebcon_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, rnebcon_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RNEBCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon_glo)
+      xmax = MAXval(rnebcon_glo)
+      PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
+
+c
+c Lecture ratqs
+c
+      ratqs_glo=0.
+      ierr = NF_INQ_VARID (nid, "RATQS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RATQS> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ratqs_glo = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ratqs_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, ratqs_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RATQS>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs_glo)
+      xmax = MAXval(ratqs_glo)
+      PRINT*,'(ecart-type) ratqs:', xmin, xmax
+c
+c Lecture run_off_lic_0
+c
+      ierr = NF_INQ_VARID (nid, "RUNOFFLIC0", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         run_off_lic_0 = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, run_off_lic_0)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, run_off_lic_0)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUNOFFLIC0>"
+            CALL abort
+         ENDIF
+      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
+
+
+c Lecture de l'energie cinetique turbulente
+c
+
+      IF (iflag_pbl>1) then
+         PRINT*, 'phyetat0: Le champ <TKE> est absent'
+         PRINT*, '          Mais je vais essayer de lire TKE**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "TKE"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "WARNING phyetat0: <TKE"//str2//"> est absent"
+              pbl_tke_glo(:,:,nsrf)=1.e-8
+           ELSE
+#ifdef NC_DOUBLE
+              ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     &                                pbl_tke_glo(1,1,nsrf))
+#else
+              ierr = NF_GET_VAR_REAL(nid, nvarid, pbl_tke_glo(1,1,nsrf))
+#endif
+              IF (ierr.NE.NF_NOERR) THEN
+                PRINT*, "WARNING phyetat0: echec lect <TKE"//str2//">"
+                CALL abort
+              ENDIF
+           ENDIF
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO k = 1, klev
+           DO i = 1, klon_glo
+              xmin = MIN(pbl_tke_glo(i,k,nsrf),xmin)
+              xmax = MAX(pbl_tke_glo(i,k,nsrf),xmax)
+           ENDDO
+           ENDDO
+           PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax
+         ENDDO
+      ENDIF
+c
+c zmax0
+      ierr = NF_INQ_VARID (nid, "ZMAX0", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         zmax0_glo=40.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmax0_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, zmax0_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ZMAX0>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(zmax0_glo)
+      xmax = MAXval(zmax0_glo)
+      PRINT*,'(ecart-type) zmax0:', xmin, xmax
+c
+c           f0(ig)=1.e-5
+c f0
+      ierr = NF_INQ_VARID (nid, "f0", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <f0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         f0_glo=1.e-5
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, f0_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, f0_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <f0>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(f0_glo)
+      xmax = MAXval(f0_glo)
+      PRINT*,'(ecart-type) f0:', xmin, xmax
+c
+c ema_work1
+c
+      ierr = NF_INQ_VARID (nid, "EMA_WORK1", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <EMA_WORK1> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ema_work1_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ema_work1_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, ema_work1_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <EMA_WORK1>"
+            CALL abort
+         ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO k = 1, klev
+           DO i = 1, klon
+              xmin = MIN(ema_work1_glo(i,k),xmin)
+              xmax = MAX(ema_work1_glo(i,k),xmax)
+           ENDDO
+           ENDDO
+           PRINT*,'ema_work1:', xmin, xmax
+      ENDIF
+c
+c ema_work2
+c
+      ierr = NF_INQ_VARID (nid, "EMA_WORK2", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <EMA_WORK2> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ema_work2_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ema_work2_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, ema_work2_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <EMA_WORK2>"
+            CALL abort
+         ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO k = 1, klev
+           DO i = 1, klon
+              xmin = MIN(ema_work2_glo(i,k),xmin)
+              xmax = MAX(ema_work2_glo(i,k),xmax)
+           ENDDO
+           ENDDO
+           PRINT*,'ema_work2:', xmin, xmax
+      ENDIF
+c
+c wake_deltat
+c
+      ierr = NF_INQ_VARID (nid, "WAKE_DELTAT", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_deltat_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_deltat_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_deltat_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <WAKE_DELTAT>"
+            CALL abort
+         ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO k = 1, klev
+           DO i = 1, klon_glo
+              xmin = MIN(wake_deltat_glo(i,k),xmin)
+              xmax = MAX(wake_deltat_glo(i,k),xmax)
+           ENDDO
+           ENDDO
+           PRINT*,'wake_deltat:', xmin, xmax
+      ENDIF
+c
+c wake_deltaq
+c
+      ierr = NF_INQ_VARID (nid, "WAKE_DELTAQ", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_deltaq_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_deltaq_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_deltaq_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <WAKE_DELTAQ>"
+            CALL abort
+         ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO k = 1, klev
+           DO i = 1, klon_glo
+              xmin = MIN(wake_deltaq_glo(i,k),xmin)
+              xmax = MAX(wake_deltaq_glo(i,k),xmax)
+           ENDDO
+           ENDDO
+           PRINT*,'wake_deltaq:', xmin, xmax
+      ENDIF
+c
+c wake_s
+c
+      ierr = NF_INQ_VARID (nid, "WAKE_S", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_s_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_s_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_s_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <WAKE_S>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_s_glo)
+      xmax = MAXval(wake_s_glo)
+      PRINT*,'(ecart-type) wake_s:', xmin, xmax
+c
+c wake_cstar
+c
+      ierr = NF_INQ_VARID (nid, "WAKE_CSTAR", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_CSTAR> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_cstar_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_cstar_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_cstar_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <WAKE_CSTAR>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_cstar_glo)
+      xmax = MAXval(wake_cstar_glo)
+      PRINT*,'(ecart-type) wake_cstar:', xmin, xmax
+c
+c wake_fip
+c
+      ierr = NF_INQ_VARID (nid, "WAKE_FIP", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_FIP> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_fip_glo=0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, wake_fip_glo)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, wake_fip_glo)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <WAKE_FIP>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_fip_glo)
+      xmax = MAXval(wake_fip_glo)
+      PRINT*,'(ecart-type) wake_fip:', xmin, xmax
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+      ENDIF ! is_mpi_root
+c
+c$OMP END MASTER
+
+c$OMP MASTER
+cym  en attendant mieux
+        iolat(1)=rlat_glo(1)
+
+!FH1D   
+!iolat(jjm+1)=rlat(klon_glo)
+	iolat(jjm+1-1/iim)=rlat_glo(klon_glo)
+        if (iim.gt.1) then
+	do i=2,jjm
+	  iolat(i)=rlat_glo(2+(i-2)*iim)
+	enddo
+        endif
+
+	CALL bcast_mpi(iolat)
+	CALL bcast_mpi(rlon_glo)
+
+!FH1D
+!       call init_iophy(iolat,rlon(2:iim+1))
+        call init_iophy(iolat,rlon_glo(2-1/iim:iim+1-1/iim))
+       
+c$OMP END MASTER
+      	
+      call Scatter( rlat_glo,rlat)
+      call Scatter( rlon_glo,rlon)
+      call Scatter( tsol_glo,ftsol)
+      IF (iflag_pbl>1) then
+         call Scatter( pbl_tke_glo,pbl_tke)
+      endif
+      call Scatter( zmax0_glo,zmax0)
+      call Scatter( f0_glo,f0)
+      call Scatter( ema_work1_glo, ema_work1)
+      call Scatter( ema_work2_glo, ema_work2)
+      call Scatter( wake_deltat_glo, wake_deltat)
+      call Scatter( wake_deltaq_glo, wake_deltaq)
+      call Scatter( wake_s_glo, wake_s)
+      call Scatter( wake_cstar_glo, wake_cstar)
+      call Scatter( wake_fip_glo, wake_fip)
+      call Scatter( tsoil,tsoil_p)
+      call Scatter( tslab,tslab_p)
+      call Scatter( seaice,seaice_p)
+      call Scatter( qsurf,qsurf_p)
+      call Scatter( qsol,qsol_p)
+      call Scatter( snow,snow_p)
+      call Scatter( alb1_glo,falb1)
+      call Scatter( alb2_glo,falb2)
+      call Scatter( evap,evap_p)
+      call Scatter( radsol_glo,radsol)
+      call Scatter( rain_fall_glo,rain_fall)
+      call Scatter( snow_fall_glo,snow_fall)
+      call Scatter( sollw_glo,sollw)
+      call Scatter( solsw_glo,solsw)
+      call Scatter( fder,fder_p)
+      call Scatter( frugs,frugs_p)
+      call Scatter( agesno,agesno_p)
+      call Scatter( zmea_glo,zmea)
+      call Scatter( zstd_glo,zstd)
+      call Scatter( zsig_glo,zsig)
+      call Scatter( zgam_glo,zgam)
+      call Scatter( zthe_glo,zthe)
+      call Scatter( zpic_glo,zpic)
+      call Scatter( zval_glo,zval)
+      call Scatter( rugsrel_glo,rugoro)
+      call Scatter( pctsrf_glo,pctsrf)
+      call Scatter( run_off_lic_0,run_off_lic_0_p)
+      call Scatter( t_ancien_glo,t_ancien)
+      call Scatter( q_ancien_glo,q_ancien)
+      call Scatter( rnebcon_glo,rnebcon)
+      call Scatter( clwcon_glo,clwcon)
+      call Scatter( ratqs_glo,ratqs)
+      call Scatter( zmasq_glo,zmasq)
+
+c
+c Initilalize variables in module surface_data
+c
+      ok_veget = ok_veget_in
+      ocean    = ocean_in
+c
+c Initialize module pbl_surface_mod 
+c
+      CALL pbl_surface_init(qsol_p, fder_p, snow_p, qsurf_p,
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Initialize ocean module according to ocean type
+      IF ( ocean == 'slab' ) THEN
+c        initilalize module ocean_slab_init
+         CALL ocean_slab_init(dtime, tslab_p, seaice_p, pctsrf)
+      ELSEIF ( ocean == 'couple' ) THEN
+c        initilalize module ocean_cpl_init
+         CALL ocean_cpl_init(dtime, rlon, rlat)
+      ELSE
+c        initilalize module ocean_forced_init
+         CALL ocean_forced_init
+      ENDIF
+c
+c Initilialize module fonte_neige_mod      
+c
+      CALL fonte_neige_init(run_off_lic_0_p)
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phyredem.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phyredem.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phyredem.F	(revision 984)
@@ -0,0 +1,1055 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE phyredem (fichnom)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE ocean_slab_mod,   ONLY : ocean_slab_final
+      USE fonte_neige_mod,  ONLY : fonte_neige_final
+      USE pbl_surface_mod,  ONLY : pbl_surface_final
+      USE surface_data,     ONLY : ocean, ok_veget
+      USE phys_state_var_mod
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ecriture de l'etat de redemarrage pour la physique
+c======================================================================
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+
+c les variables globales ecrites dans le fichier restart
+      REAL rlat_glo(klon_glo), rlon_glo(klon_glo)
+      REAL pctsrf_glo(klon_glo, nbsrf)
+      REAL tsol_glo(klon_glo,nbsrf)
+      REAL alb1_glo(klon_glo,nbsrf)
+      REAL alb2_glo(klon_glo,nbsrf)
+      REAL rain_fall_glo(klon_glo)
+      REAL snow_fall_glo(klon_glo)
+      real solsw_glo(klon_glo)
+      real sollw_glo(klon_glo)
+      REAL radsol_glo(klon_glo)
+      REAL zmea_glo(klon_glo)
+      REAL zstd_glo(klon_glo)
+      REAL zsig_glo(klon_glo)
+      REAL zgam_glo(klon_glo)
+      REAL zthe_glo(klon_glo)
+      REAL zpic_glo(klon_glo)
+      REAL zval_glo(klon_glo)
+      REAL rugsrel_glo(klon_glo)
+      REAL t_ancien_glo(klon_glo,klev), q_ancien_glo(klon_glo,klev)
+      REAL clwcon_glo(klon_glo,klev)
+      REAL rnebcon_glo(klon_glo,klev) 
+      REAL ratqs_glo(klon_glo,klev)
+      REAL pbl_tke_glo(klon_glo,klev+1,nbsrf)
+      REAL zmax0_glo(klon_glo), f0_glo(klon)
+      REAL ema_work1_glo(klon_glo, klev), ema_work2_glo(klon_glo, klev)
+      REAL wake_deltat_glo(klon_glo,klev),wake_deltaq_glo(klon_glo,klev)
+      REAL wake_s_glo(klon_glo), wake_cstar_glo(klon_glo)
+      REAL wake_fip_glo(klon_glo)
+
+cIM "slab" ocean
+      REAL tsoil_p(klon,nsoilmx,nbsrf)
+      REAL tslab_p(klon), seaice_p(klon)
+      REAL qsurf_p(klon,nbsrf)
+      REAL qsol_p(klon)
+      REAL snow_p(klon,nbsrf)
+      REAL evap_p(klon,nbsrf)
+      real fder_p(klon)
+      REAL frugs_p(klon,nbsrf)
+      REAL agesno_p(klon,nbsrf)
+      REAL run_off_lic_0_p(klon)
+      
+      REAL tsoil(klon_glo,nsoilmx,nbsrf)
+      REAL tslab(klon_glo), seaice(klon_glo)
+      REAL qsurf(klon_glo,nbsrf)
+      REAL qsol(klon_glo)
+      REAL snow(klon_glo,nbsrf)
+      REAL evap(klon_glo,nbsrf)
+      real fder(klon_glo)
+      REAL frugs(klon_glo,nbsrf)
+      REAL agesno(klon_glo,nbsrf)
+      REAL run_off_lic_0(klon_glo)
+      REAL masq(klon_glo)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+c
+      INTEGER isoil, nsrf
+      CHARACTER (len=7) :: str7
+      CHARACTER (len=2) :: str2
+
+c======================================================================
+c 
+c Get variables which will be written to restart file from module 
+c pbl_surface_mod
+      CALL pbl_surface_final(qsol_p, fder_p, snow_p, qsurf_p, 
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Get a variable calculated in module fonte_neige_mod
+      CALL fonte_neige_final(run_off_lic_0_p)
+
+c If slab ocean then get 2 varaibles from module ocean_slab_mod
+      IF ( ocean == 'slab' ) THEN
+         CALL ocean_slab_final(tslab_p, seaice_p)
+      ELSE 
+         tslab_p(:)  = 0.0
+         seaice_p(:) = 0.0
+      ENDIF      
+
+c======================================================================
+
+      call Gather( rlat,rlat_glo)
+      call Gather( rlon,rlon_glo)
+      call Gather( pctsrf,pctsrf_glo)
+      call Gather( ftsol,tsol_glo)
+      call Gather( falb1,alb1_glo)
+      call Gather( falb2,alb2_glo)
+      call Gather( rain_fall,rain_fall_glo)
+      call Gather( snow_fall,snow_fall_glo)
+      call Gather( sollw,sollw_glo)
+      call Gather( solsw,solsw_glo)
+      call Gather( radsol,radsol_glo)
+      call Gather( zmea,zmea_glo)
+      call Gather( zstd,zstd_glo)
+      call Gather( zsig,zsig_glo)
+      call Gather( zgam,zgam_glo)
+      call Gather( zthe,zthe_glo)
+      call Gather( zpic,zpic_glo)
+      call Gather( zval,zval_glo)
+      call Gather( rugoro,rugsrel_glo)
+      call Gather( t_ancien,t_ancien_glo)
+      call Gather( q_ancien,q_ancien_glo)
+      call Gather( clwcon,clwcon_glo)
+      call Gather( rnebcon,rnebcon_glo)
+      call Gather( ratqs,ratqs_glo)
+      call Gather( pbl_tke,pbl_tke_glo)
+      call Gather( zmax0,zmax0_glo)
+      call Gather( f0,f0_glo)
+      call Gather( ema_work1, ema_work1_glo)
+      call Gather( ema_work2, ema_work2_glo)
+      call Gather( wake_deltat, wake_deltat_glo)
+      call Gather( wake_deltaq, wake_deltaq_glo)
+      call Gather( wake_s, wake_s_glo)
+      call Gather( wake_cstar, wake_cstar_glo)
+      call Gather( wake_fip, wake_fip_glo)
+
+      call Gather( tsoil_p,tsoil)
+      call Gather( tslab_p,tslab)
+      call Gather( seaice_p,seaice)
+      call Gather( qsurf_p,qsurf)
+      call Gather( qsol_p,qsol)
+      call Gather( snow_p,snow)
+      call Gather( evap_p,evap)
+      call Gather( fder_p,fder)
+      call Gather( frugs_p,frugs)
+      call Gather( agesno_p,agesno)
+      call Gather( run_off_lic_0_p,run_off_lic_0)
+      call Gather( zmasq,masq)
+      
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//fichnom
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
+     .                       "Fichier redemmarage physique")
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim1)
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, idim2)
+      ierr = NF_DEF_DIM (nid, "horizon_vertical", klon_glo*klev, idim3)
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      tab_cntrl(1) = dtime
+      tab_cntrl(2) = radpas
+      tab_cntrl(3) = co2_ppm
+      tab_cntrl(4) = solaire
+      tab_cntrl(5) = iflag_con
+      tab_cntrl(6) = nbapp_rad
+
+      IF( cycle_diurne ) tab_cntrl( 7 ) = 1.
+      IF(   soil_model ) tab_cntrl( 8 ) = 1.
+      IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+      IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+      IF(     ok_orolf ) tab_cntrl(11 ) = 1.
+
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = annee_ref
+      tab_cntrl(15) = itau_phy
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Longitudes de la grille physique")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31,
+     .                        "Latitudes de la grille physique")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat_glo)
+#endif
+c
+C PB ajout du masque terre/mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "masque", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16,
+     .                        "masque terre mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masq)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masq)
+#endif      
+c BP ajout des fraction de chaque sous-surface
+C
+C 1. fraction de terre 
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "fraction de continent")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo,     &
+     &   is_ter))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo,       &
+     &    is_ter))
+#endif
+C 
+C 2. Fraction de glace de terre
+C 
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24,
+     .                        "fraction glace de terre")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo,
+     &                          is_lic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo, 
+     &                        is_lic))
+#endif
+C
+C 3. fraction ocean
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "fraction ocean")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo,
+     &                          is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo,
+     &                        is_oce))
+#endif
+C
+C 4. Fraction glace de mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                        "fraction glace mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf_glo(1 : klon_glo, 
+     &                          is_sic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf_glo(1 : klon_glo,
+     &                         is_sic))
+#endif
+C
+C
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Temperature de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol_glo(1,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol_glo(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+      DO isoil=1, nsoilmx
+        IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+        WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29,
+     .                        "Temperature du sol No."//str7)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de couches"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf))
+#endif
+      ENDDO
+      ENDDO
+c
+cIM "slab" ocean
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TSLAB", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TSLAB", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Ecart de la SST (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tslab)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tslab)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "SEAICE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "SEAICE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Glace de mer kg/m2 (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,seaice)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,seaice)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
+     .                        "Humidite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsurf(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsurf(1,nsrf))
+#endif
+      END DO
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"QSOL",NF_DOUBLE,1,idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"QSOL",NF_FLOAT,1,idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .    "Eau dans le sol (mm)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alb1_glo(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,alb1_glo(1,nsrf))
+#endif
+      ENDDO
+
+        DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo LW de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alb2_glo(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,alb2_glo(1,nsrf))
+#endif
+      ENDDO
+c
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Evaporation de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf))
+#endif
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Neige de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf))
+#endif
+      ENDDO
+
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Rayonnement net a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Rayonnement solaire a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27,
+     .                        "Rayonnement IF a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "Derive de flux")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,fder)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "precipitation liquide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                        "precipitation solide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall_glo)
+#endif
+c
+       endif
+c$OMP END MASTER
+cc ----> necessaire pour eviter bug openMP sur SX6
+c$OMP MASTER
+      if (is_mpi_root) then
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "rugosite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_DOUBLE,1,idim2
+     $          ,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2
+     $          ,nvarid)
+#endif
+            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Age de la neige surface No."//str2)
+            ierr = NF_ENDDEF(nid)
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno(1,nsrf))
+#endif
+      ENDDO
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd_glo)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig_glo)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam_glo)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe_glo)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic_glo)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval_glo)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Longueur de rugosite sur mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce))
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Eau liquide convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,clwcon_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,clwcon_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Nebulosite convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rnebcon_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rnebcon_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Ratqs")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ratqs_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ratqs_glo)
+#endif
+c
+c run_off_lic_0
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_DOUBLE,1,idim2,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_FLOAT, 1,idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 10,
+     .                        "Runofflic0")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,run_off_lic_0)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,run_off_lic_0)
+#endif
+c
+c
+!!!!!!!!!!!!!!!!!!!! DEB TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+c
+      IF (iflag_pbl>1) then
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+            ierr = NF_DEF_VAR (nid,"TKE"//str2,NF_DOUBLE,1,idim3
+     $          ,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,"TKE"//str2,NF_FLOAT,1,idim3
+     $          ,nvarid)
+#endif
+            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Energ. Cineti. Turb."//str2)
+            ierr = NF_ENDDEF(nid)
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pbl_tke_glo(:,:,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pbl_tke_glo(:,:,nsrf))
+#endif
+      ENDDO
+      ENDIF
+
+!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+cIM ajout zmax0, f0, ema_work1, ema_work2
+cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_fip
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZMAX0", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZMAX0", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmax0_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmax0_glo)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "F0", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "F0", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,f0_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,f0_glo)
+#endif
+c ema_work1
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "EMA_WORK1", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "EMA_WORK1", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ema_work1_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ema_work1_glo)
+#endif
+c ema_work2
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "EMA_WORK2", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "EMA_WORK2", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ema_work2_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ema_work2_glo)
+#endif
+c wake_deltat
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "WAKE_DELTAT", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "WAKE_DELTAT", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_deltat_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_deltat_glo)
+#endif
+c wake_deltaq
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "WAKE_DELTAQ", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "WAKE_DELTAQ", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_deltaq_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_deltaq_glo)
+#endif
+c wake_s
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "WAKE_S", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "WAKE_S", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_s_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_s_glo)
+#endif
+c wake_cstar
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "WAKE_CSTAR", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "WAKE_CSTAR", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_cstar_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_cstar_glo)
+#endif
+c wake_fip
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "WAKE_FIP", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "WAKE_FIP", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,wake_fip_glo)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,wake_fip_glo)
+#endif
+c
+      ierr = NF_CLOSE(nid)
+c
+      endif   ! is_mpi_root
+c$OMP END MASTER
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phys_local_var_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phys_local_var_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phys_local_var_mod.F90	(revision 984)
@@ -0,0 +1,95 @@
+      MODULE phys_local_var_mod
+! Variables locales pour effectuer les appels en serie
+!======================================================================
+!
+!
+!======================================================================
+! Declaration des variables
+
+      REAL, ALLOCATABLE :: t_seri(:,:), q_seri(:,:)
+      REAL, ALLOCATABLE :: ql_seri(:,:),qs_seri(:,:)
+      REAL, ALLOCATABLE :: u_seri(:,:), v_seri(:,:)
+
+      REAL, ALLOCATABLE :: tr_seri(:,:,:)
+      REAL, ALLOCATABLE :: d_t_dyn(:,:), d_q_dyn(:,:)
+      REAL, ALLOCATABLE :: d_t_con(:,:),d_q_con(:,:)
+      REAL, ALLOCATABLE :: d_u_con(:,:),d_v_con(:,:)
+      REAL, ALLOCATABLE :: d_t_wake(:,:),d_q_wake(:,:)
+      REAL, ALLOCATABLE :: d_t_lsc(:,:),d_q_lsc(:,:),d_ql_lsc(:,:)
+      REAL, ALLOCATABLE :: d_t_ajsb(:,:), d_q_ajsb(:,:)
+      REAL, ALLOCATABLE :: d_t_ajs(:,:), d_q_ajs(:,:)
+      REAL, ALLOCATABLE :: d_u_ajs(:,:), d_v_ajs(:,:)
+      REAL, ALLOCATABLE :: d_t_eva(:,:),d_q_eva(:,:)
+!tendances dues a oro et lif
+      REAL, ALLOCATABLE :: d_t_oli(:,:)
+      REAL, ALLOCATABLE :: d_u_oli(:,:), d_v_oli(:,:)
+      REAL, ALLOCATABLE :: d_t_vdf(:,:), d_q_vdf(:,:)
+      REAL, ALLOCATABLE :: d_u_vdf(:,:), d_v_vdf(:,:)
+      REAL, ALLOCATABLE :: d_t_oro(:,:)
+      REAL, ALLOCATABLE :: d_u_oro(:,:), d_v_oro(:,:)
+      REAL, ALLOCATABLE :: d_t_lif(:,:)
+      REAL, ALLOCATABLE :: d_u_lif(:,:), d_v_lif(:,:)
+! tendance du a la conersion Ec -> E thermique
+      REAL, ALLOCATABLE :: d_t_ec(:,:)
+      REAL, ALLOCATABLE :: d_ts(:,:), d_tr(:,:,:)
+CONTAINS
+
+!======================================================================
+SUBROUTINE phys_local_var_init
+use dimphy
+IMPLICIT NONE
+#include "indicesol.h"
+      allocate(t_seri(klon,klev),q_seri(klon,klev),ql_seri(klon,klev),qs_seri(klon,klev))
+      allocate(u_seri(klon,klev),v_seri(klon,klev))
+
+      allocate(tr_seri(klon,klev,nbtr))
+      allocate(d_t_dyn(klon,klev),d_q_dyn(klon,klev))
+      allocate(d_t_con(klon,klev),d_q_con(klon,klev))
+      allocate(d_u_con(klon,klev),d_v_con(klon,klev))
+      allocate(d_t_wake(klon,klev),d_q_wake(klon,klev))
+      allocate(d_t_lsc(klon,klev),d_q_lsc(klon,klev))
+      allocate(d_ql_lsc(klon,klev))
+      allocate(d_t_ajsb(klon,klev),d_q_ajsb(klon,klev))
+      allocate(d_t_ajs(klon,klev),d_q_ajs(klon,klev))
+      allocate(d_u_ajs(klon,klev),d_v_ajs(klon,klev))
+      allocate(d_t_eva(klon,klev),d_q_eva(klon,klev))
+      allocate(d_t_vdf(klon,klev),d_q_vdf(klon,klev))
+      allocate(d_u_vdf(klon,klev),d_v_vdf(klon,klev))
+      allocate(d_t_oli(klon,klev),d_t_oro(klon,klev))
+      allocate(d_u_oli(klon,klev),d_v_oli(klon,klev))
+      allocate(d_u_oro(klon,klev),d_v_oro(klon,klev))
+      allocate(d_t_lif(klon,klev),d_t_ec(klon,klev))
+      allocate(d_u_lif(klon,klev),d_v_lif(klon,klev))
+      allocate(d_ts(klon,klev), d_tr(klon,klev,nbtr))
+END SUBROUTINE phys_local_var_init
+
+!======================================================================
+SUBROUTINE phys_local_var_end
+use dimphy
+IMPLICIT NONE
+#include "indicesol.h"
+      deallocate(t_seri,q_seri,ql_seri,qs_seri)
+      deallocate(u_seri,v_seri)
+
+      deallocate(tr_seri)
+      deallocate(d_t_dyn,d_q_dyn)
+      deallocate(d_t_con,d_q_con)
+      deallocate(d_u_con,d_v_con)
+      deallocate(d_t_wake,d_q_wake)
+      deallocate(d_t_lsc,d_q_lsc)
+      deallocate(d_ql_lsc)
+      deallocate(d_t_ajsb,d_q_ajsb)
+      deallocate(d_t_ajs,d_q_ajs)
+      deallocate(d_u_ajs,d_v_ajs)
+      deallocate(d_t_eva,d_q_eva)
+      deallocate(d_t_vdf,d_q_vdf)
+      deallocate(d_u_vdf,d_v_vdf)
+      deallocate(d_t_oli,d_t_oro)
+      deallocate(d_u_oli,d_v_oli)
+      deallocate(d_u_oro,d_v_oro)
+      deallocate(d_t_lif,d_t_ec)
+      deallocate(d_u_lif,d_v_lif)
+      deallocate(d_ts, d_tr)
+END SUBROUTINE phys_local_var_end
+
+END MODULE phys_local_var_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phys_output_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phys_output_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phys_output_mod.F90	(revision 984)
@@ -0,0 +1,793 @@
+! Abderrahmane 12 2007
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! Ecreture des Sorties du modele dans les fichiers Netcdf :
+! histmth.nc : moyennes mensuelles
+! histday.nc : moyennes journalieres
+! histhf.nc  : moyennes toutes les 3 heures
+! histins.nc : valeurs instantanees
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MODULE phys_output_mod
+
+  IMPLICIT NONE
+
+   integer, parameter                           :: nfiles = 4
+   logical, dimension(nfiles), save             :: clef_files
+   integer, dimension(nfiles), save             :: lev_files
+   integer, dimension(nfiles), save             :: nid_files
+
+   integer, dimension(nfiles), save             :: nhorim, nvertm
+   real, dimension(nfiles), save                :: zstophym, zoutm
+   CHARACTER(len=20), dimension(nfiles), save   :: type_ecri
+
+!   integer, save                     :: nid_hf3d 
+
+!!!!!!!!!! stockage dans une region limitee pour chaque fichier !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!                 entre [lonmin_reg,lonmax_reg] et [latmin_reg,latmax_reg]
+
+  logical, dimension(nfiles), save  :: ok_reglim         = (/ .false., .false., .false., .false. /) 
+  real, dimension(nfiles), save     :: lonmin_reg        = (/ 0., -45., 0., 0. /)
+  real, dimension(nfiles), save     :: lonmax_reg        = (/ 90., 45., 90., 90. /)
+  real, dimension(nfiles), save     :: latmin_reg        = (/ 0., -45., 0., 0. /)
+  real, dimension(nfiles), save     :: latmax_reg        = (/ 90., 90., 90., 90. /)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition pour chaque variable du niveau d ecriture dans chaque fichier
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!/ histmth, histday, histhf, histins /)!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!! 1D
+  integer, dimension(nfiles) , save :: flag_phis         = (/ 1, 1, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_aire         = (/ 1, 1, 10,  1 /)
+  integer, dimension(nfiles) , save :: flag_contfracATM  = (/ 10, 1,  1, 10 /)
+  integer, dimension(nfiles) , save :: flag_contfracOR   = (/ 10, 1,  1, 10 /)
+  integer, dimension(nfiles) , save :: flag_aireTER      = (/ 10, 10, 1, 10 /)
+  
+!!! 2D
+  integer, dimension(nfiles) , save :: flag_flat         = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_slp          = (/ 1, 1, 1, 10 /)
+  integer, dimension(nfiles) , save :: flag_tsol         = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_t2m          = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_t2m_min      = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_t2m_max      = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_t2m_sol      = (/ 10, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_wind10m      = (/ 1, 1, 1, 10 /)
+  integer, dimension(nfiles) , save :: flag_wind10max    = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_sicf         = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_q2m          = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_u10m         = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_v10m         = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_psol         = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_qsurf        = (/ 1, 10, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_u10m_sol     = (/ 10, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_v10m_sol     = (/ 10, 4, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_qsol         = (/ 1, 10, 10, 1 /)
+
+  integer, dimension(nfiles),save   :: flag_ndayrain     = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles),save   :: flag_precip       = (/ 1, 1, 1, 1 /)
+  integer,  dimension(nfiles), save :: flag_plul         = (/ 1, 1, 1, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_pluc         = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_snow         = (/ 1, 1, 10, 1 /) 
+  integer, dimension(nfiles) , save :: flag_evap         = (/ 1, 1, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_tops         = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tops0        = (/ 1, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_topl         = (/ 1, 1, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_topl0        = (/ 1, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWupTOA      = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWupTOAclr   = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWdnTOA      = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWdnTOAclr   = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWup200      = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWup200clr   = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWdn200      = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWdn200clr   = (/ 10, 1, 10, 10 /)
+
+! arajouter
+!  integer, dimension(nfiles) , save :: flag_LWupTOA     = (/ 1, 4, 10, 10 /)
+!  integer, dimension(nfiles) , save :: flag_LWupTOAclr  = (/ 1, 4, 10, 10 /)
+!  integer, dimension(nfiles) , save :: flag_LWdnTOA     = (/ 1, 4, 10, 10 /)
+!  integer, dimension(nfiles) , save :: flag_LWdnTOAclr  = (/ 1, 4, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_LWup200      = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWup200clr   = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWdn200      = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWdn200clr   = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_sols         = (/ 1, 1, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_sols0        = (/ 1, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_soll         = (/ 1, 1, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_soll0        = (/ 1, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_radsol       = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWupSFC      = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWupSFCclr   = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWdnSFC      = (/ 1, 1, 10, 10 /) 
+  integer, dimension(nfiles) , save :: flag_SWdnSFCclr   = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWupSFC      = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWupSFCclr   = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWdnSFC      = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWdnSFCclr   = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_bils         = (/ 1, 2, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_sens         = (/ 1, 1, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_fder         = (/ 1, 2, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_ffonte       = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_fqcalving    = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_fqfonte      = (/ 1, 10, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_taux_sol     = (/ 1, 4, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_tauy_sol     = (/ 1, 4, 10, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_pourc_sol    = (/ 1, 4, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_fract_sol    = (/ 1, 4, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_tsol_sol     = (/ 1, 4, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_sens_sol     = (/ 1, 4, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_lat_sol      = (/ 1, 4, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_flw_sol      = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_fsw_sol      = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_wbils_sol    = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_wbilo_sol    = (/ 1, 10, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_cdrm         = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_cdrh         = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_cldl         = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_cldm         = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_cldh         = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_cldt         = (/ 1, 1, 2, 10 /)
+  integer, dimension(nfiles) , save :: flag_cldq         = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_lwp          = (/ 1, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_iwp          = (/ 1, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ue           = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ve           = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_uq           = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_vq           = (/ 1, 10, 10, 10 /)
+ 
+  integer, dimension(nfiles) , save :: flag_cape         = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_pbase        = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ptop         = (/ 1, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_fbase        = (/ 1, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_prw          = (/ 1, 1, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_s_pblh       = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_pblt       = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_lcl       = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_capCL      = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_oliqCL    = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_cteiCL     = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_therm      = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_trmb1      = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_trmb2      = (/ 1, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_s_trmb3      = (/ 1, 10, 10, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_slab_bils    = (/ 1, 1, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_ale_bl    = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_alp_bl    = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_ale_wk    = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_alp_wk    = (/ 1, 1, 1, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_ale       = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_alp       = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_cin       = (/ 1, 1, 1, 1 /)
+  integer, dimension(nfiles) , save :: flag_wape       = (/ 1, 1, 1, 1 /)
+
+
+! Champs interpolles sur des niveaux de pression ??? a faire correctement
+! if=1 on ecrit u v w phi sur 850 700 500 200 au niv 1
+! if=2 on ecrit w et ph 500 seulement au niv 1
+!        et u v sur 850 700 500 200
+! if=3 on ecrit ph a 500 seulement au niv 1
+!      on ecrit u v t q a 850 700 500 200 au niv 3
+!      on ecrit ph  a 500   au niv 3
+
+  integer, dimension(nfiles) , save :: flag_ulevsSTD     = (/ 1, 1, 3, 10 /)
+  integer, dimension(nfiles) , save :: flag_vlevsSTD     = (/ 1, 1, 3, 10 /)
+  integer, dimension(nfiles) , save :: flag_wlevsSTD     = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tlevsSTD     = (/ 10, 10, 3, 10 /)
+  integer, dimension(nfiles) , save :: flag_qlevsSTD     = (/ 10, 10, 3, 10 /)
+  integer, dimension(nfiles) , save :: flag_philevsSTD   = (/ 1, 1, 1, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_fluxo        = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_fluxg        = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_t_oce_sic    = (/ 1, 10, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_lmt_bils     = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tslab        = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_seaice       = (/ 1, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_siceh        = (/ 1, 1, 10, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_weakinv      = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dthmin       = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_u10_sol      = (/ 10, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_v10_sol      = (/ 10, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_meantaucld   = (/ 10, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_cldtau       = (/ 10, 5, 10, 10 /)                     
+  integer, dimension(nfiles) , save :: flag_cldemi       = (/ 10, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_rh2m         = (/ 10, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_qsat2m       = (/ 10, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tpot         = (/ 10, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tpote        = (/ 10, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tke          = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tke_max      = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tke_sol      = (/ 10, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_tke_max_sol  = (/ 10, 4, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_kz           = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_kz_max       = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWnetOR      = (/ 10, 10, 2, 10 /)
+  integer, dimension(nfiles) , save :: flag_SWdownOR     = (/ 10, 10, 2, 10 /)
+  integer, dimension(nfiles) , save :: flag_LWdownOR     = (/ 10, 10, 2, 10 /)
+
+  integer, dimension(nfiles) , save :: flag_snowl         = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_cape_max      = (/ 10, 1, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_solldown      = (/ 10, 1, 10, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_dtsvdfo       = (/ 10, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_dtsvdft       = (/ 10, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_dtsvdfg       = (/ 10, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_dtsvdfi       = (/ 10, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_rugs          = (/ 10, 10, 10, 1 /)
+
+!!!!!!!!!!!!!!!!!!!!!! 3D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+  integer, dimension(nfiles) , save :: flag_lwcon        = (/ 2, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_iwcon        = (/ 2, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_temp         = (/ 2, 3, 4, 1 /)
+  integer, dimension(nfiles) , save :: flag_theta         = (/ 2, 3, 4, 1 /)
+  integer, dimension(nfiles) , save :: flag_ovap         = (/ 2, 3, 4, 1 /)
+  integer, dimension(nfiles) , save :: flag_wvapp        = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_geop         = (/ 2, 3, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_vitu         = (/ 2, 3, 4, 1 /)
+  integer, dimension(nfiles) , save :: flag_vitv         = (/ 2, 3, 4, 1 /)
+  integer, dimension(nfiles) , save :: flag_vitw         = (/ 2, 3, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_pres         = (/ 2, 3, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_rneb         = (/ 2, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_rnebcon      = (/ 2, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_rhum         = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ozone        = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_upwd         = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtphy        = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqphy        = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_pr_con_l     = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_pr_con_i     = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_pr_lsc_l     = (/ 2, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_pr_lsc_i     = (/ 2, 10, 10, 10 /)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  integer, dimension(nfiles) , save :: flag_albe_sol     = (/ 3, 4, 10, 1 /) 
+  integer, dimension(nfiles) , save :: flag_ages_sol     = (/ 3, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_rugs_sol     = (/ 3, 4, 10, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_albs         = (/ 3, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_albslw       = (/ 3, 10, 10, 1 /)
+
+  integer, dimension(nfiles) , save :: flag_clwcon       = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_Ma           = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dnwd         = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dnwd0        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtdyn        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqdyn        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtcon        = (/ 4, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ducon        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqcon        = (/ 4, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtwak        = (/ 4, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqwak        = (/ 4, 5, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtlsc        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtlschr      = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqlsc        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtvdf        = (/ 4, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_dqvdf        = (/ 4, 10, 10, 1 /)
+  integer, dimension(nfiles) , save :: flag_dteva        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqeva        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ptconv       = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_ratqs        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtthe        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_f_th        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_e_th        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_d_th        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_f0_th        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_zmax_th        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqthe        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtajs        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dqajs        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtswr        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtsw0        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtlwr        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtlw0        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dtec         = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_duvdf        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dvvdf        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_duoro        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dvoro        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dulif        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_dvlif        = (/ 4, 10, 10, 10 /)
+  integer, dimension(nfiles) , save :: flag_trac         = (/ 4, 10, 10, 10 /)
+
+    CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!! Ouverture des fichier et definition des variable de sortie !!!!!!!!
+!! histbeg, histvert et histdef
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+  
+  SUBROUTINE phys_output_open(jjmp1,nqmax,nlevSTD,clevSTD,nbteta, &
+                              ctetaSTD,dtime, presnivs, ok_veget, &
+                              ocean, iflag_pbl,ok_mensuel,ok_journe, & 
+                              ok_hf,ok_instan, nid_fil)
+
+  USE iophy 
+  USE dimphy
+  USE ioipsl
+  USE mod_phys_lmdz_para
+
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "temps.h"
+  include "indicesol.h"
+  include "advtrac.h"
+  include "clesphys.h"
+  include "thermcell.h"
+
+  integer                               :: jjmp1, nqmax
+  integer                               :: nbteta, nlevSTD, radpas
+  logical                               :: ok_mensuel, ok_journe, ok_hf, ok_instan
+  real                                  :: dtime
+  integer                               :: idayref
+  real                                  :: zjulian
+  real, dimension(klev)                 :: presnivs
+  character(len=4), dimension(nlevSTD)  :: clevSTD
+  integer                               :: nsrf, k, iq, iiq, iff, i, j
+  logical                               :: ok_veget
+  integer                               :: iflag_pbl
+  CHARACTER(len=3)                      :: bb2
+  CHARACTER(len=2)                      :: bb3
+  character(len=6)                      :: ocean
+  CHARACTER(len=3)                      :: ctetaSTD(nbteta)
+  integer, dimension(nfiles)            :: nid_fil
+  real, dimension(nfiles)               :: ecrit_files
+  CHARACTER(len=20), dimension(nfiles)  :: name_files
+  INTEGER, dimension(iim*jjmp1)         ::  ndex2d
+  INTEGER, dimension(iim*jjmp1*klev)    :: ndex3d
+  integer                               :: imin_ins, imax_ins
+  integer                               :: jmin_ins, jmax_ins
+
+   name_files(1) = 'histmth'
+   name_files(2) = 'histday'
+   name_files(3) = 'histhf'
+   name_files(4) = 'histins'
+
+   type_ecri(1) = 'ave(X)'
+   type_ecri(2) = 'ave(X)'
+   type_ecri(3) = 'ave(X)'
+   type_ecri(4) = 'inst(X)'
+
+   clef_files(1) = ok_mensuel
+   clef_files(2) = ok_journe
+   clef_files(3) = ok_hf
+   clef_files(4) = ok_instan
+
+   lev_files(1) = lev_histmth
+   lev_files(2) = lev_histday
+   lev_files(3) = lev_histhf
+   lev_files(4) = 1
+
+   ecrit_files(1) = ecrit_mth
+   ecrit_files(2) = ecrit_day
+   ecrit_files(3) = ecrit_hf
+   ecrit_files(4) = ecrit_ins
+ 
+!!!!!!!!!!!!!!!!!!!!!!! Boucle sur les fichiers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Appel de histbeg et histvert pour creer le fichier et les niveaux verticaux !!
+! Appel des histbeg pour definir les variables (nom, moy ou inst, freq de sortie ..
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ DO iff=1,nfiles
+
+    IF (clef_files(iff)) THEN
+      
+      zstophym(iff) = dtime         ! Frequence ou l on moyenne
+      zoutm(iff) = ecrit_files(iff) ! Frequence ou l on ecrit
+
+      idayref = day_ref
+      CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+
+!!!!!!!!!!!!!!!!! Traitement dans le cas ou l'on veut stocker sur un domaine limite !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+     if (ok_reglim(iff)) then
+
+        imin_ins=1
+        imax_ins=iim
+        jmin_ins=1
+        jmax_ins=jjmp1
+
+        do i=1,iim-1
+           print*,'io_lon(i)=',io_lon(i)
+           if (io_lon(i).le.lonmin_reg(iff)) imin_ins=i
+           if (io_lon(i).le.lonmax_reg(iff)) imax_ins=i
+        enddo
+
+        do j=1,jjmp1-1
+            print*,'io_lat(j)=',io_lat(j)
+            if (io_lat(j).ge.latmin_reg(iff)) jmax_ins=j+1
+            if (io_lat(j).ge.latmax_reg(iff)) jmin_ins=j
+        enddo
+
+         print*,'On stoke le fichier hist sur, ', &
+         imin_ins,imax_ins,jmin_ins,jmax_ins
+         print*,'On stoke le fichier instantanne sur, ', &
+         io_lon(imin_ins),io_lon(imax_ins), &
+         io_lat(jmin_ins),io_lat(jmax_ins)
+
+ CALL histbeg(name_files(iff),iim,io_lon,jjmp1,io_lat, &
+              imin_ins,imax_ins-imin_ins+1, &
+              jmin_ins,jmax_ins-jmin_ins+1, &
+              itau_phy,zjulian,dtime,nhorim(iff),nid_fil(iff))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+       else
+ CALL histbeg_phy(name_files(iff),itau_phy,zjulian,dtime,nhorim(iff),nid_fil(iff))
+       endif
+ 
+      nid_files(iff)=nid_fil(iff)
+
+ CALL histvert(nid_files(iff),"presnivs","Vertical levels","mb",klev, presnivs/100., nvertm(iff))
+
+!!!!!!!!!!!!! Traitement des champs 3D pour histhf !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!! A Revoir plus tard !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!          IF (iff.eq.3.and.lev_files(iff).ge.4) THEN
+!          CALL histbeg_phy("histhf3d",itau_phy, &
+!     &                     zjulian, dtime, &
+!     &                     nhorim, nid_hf3d)
+
+!         CALL histvert(nid_hf3d,"presnivs", &
+!     &                 "Vertical levels","mb", &
+!     &                 klev, presnivs/100., nvertm)
+!          ENDIF
+
+!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CALL histdef2d(iff,flag_phis,"phis","Surface geop.height","m2/s2") 
+ CALL histdef2d(iff,flag_aire,"aire","Grid area","-")
+ CALL histdef2d(iff,flag_contfracATM,"contfracATM","% sfce ter+lic","-")
+ CALL histdef2d(iff,flag_contfracOR,"contfracOR","% sfce terre OR","-" )
+ CALL histdef2d(iff,flag_aireTER,"aireTER","Grid area CONT","-" )
+
+!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CALL histdef2d(iff,flag_flat,"flat","Latent heat flux","W/m2")
+ CALL histdef2d(iff,flag_slp,"slp","Sea Level Pressure", "Pa" )
+ CALL histdef2d(iff,flag_tsol,"tsol","Surface Temperature", "K")
+ CALL histdef2d( iff,flag_t2m,"t2m","Temperature 2m", "K" )
+ CALL histdef2d(iff,flag_t2m_min,"t2m_min","Temp 2m min", "K" )
+ CALL histdef2d(iff,flag_t2m_max,"t2m_max", "Temp 2m max", "K" )
+ CALL histdef2d(iff,flag_wind10m,"wind10m","10-m wind speed","m/s")
+ CALL histdef2d(iff,flag_wind10max,"wind10max","10m wind speed max","m/s")
+ CALL histdef2d(iff,flag_sicf,"sicf","Sea-ice fraction", "-" )
+ CALL histdef2d(iff,flag_q2m,"q2m","Specific humidity 2m", "kg/kg")
+ CALL histdef2d(iff,flag_u10m,"u10m","Vent zonal 10m", "m/s" )
+ CALL histdef2d(iff,flag_v10m,"v10m","Vent meridien 10m", "m/s")
+ CALL histdef2d(iff,flag_psol,"psol","Surface Pressure","Pa" ) 
+ CALL histdef2d(iff,flag_qsurf,"qsurf","Surface Air humidity", "kg/kg")
+
+  if (.not. ok_veget) then
+ CALL histdef2d(iff,flag_qsol,"qsol","Soil watter content", "mm" )
+  endif
+
+ CALL histdef2d(iff,flag_ndayrain,"ndayrain","Number of dayrain(liq+sol)","-")
+ CALL histdef2d(iff,flag_precip,"precip","Precip Totale liq+sol","kg/(s*m2)" )
+ CALL histdef2d(iff,flag_plul,"plul","Large-scale Precip.","kg/(s*m2)") 
+ CALL histdef2d(iff,flag_pluc,"pluc","Convective Precip.","kg/(s*m2)")
+ CALL histdef2d(iff,flag_snow,"snow","Snow fall","kg/(s*m2)" )
+ CALL histdef2d(iff,flag_evap,"evap","Evaporat", "kg/(s*m2)" ) 
+ CALL histdef2d(iff,flag_tops,"tops","Solar rad. at TOA","W/m2") 
+ CALL histdef2d(iff,flag_tops0,"tops0","CS Solar rad. at TOA", "W/m2")
+ CALL histdef2d(iff,flag_topl,"topl","IR rad. at TOA", "W/m2" )
+ CALL histdef2d(iff,flag_topl0,"topl0", "IR rad. at TOA","W/m2")
+ CALL histdef2d(iff,flag_SWupTOA,"SWupTOA","SWup at TOA","W/m2") 
+ CALL histdef2d(iff,flag_SWupTOAclr,"SWupTOAclr","SWup clear sky at TOA","W/m2")
+ CALL histdef2d(iff,flag_SWdnTOA, "SWdnTOA","SWdn at TOA","W/m2" )
+ CALL histdef2d(iff,flag_SWdnTOAclr,"SWdnTOAclr","SWdn clear sky at TOA","W/m2") 
+ CALL histdef2d(iff,flag_SWup200,"SWup200","SWup at 200mb","W/m2" ) 
+ CALL histdef2d(iff,flag_SWup200clr,"SWup200clr","SWup clear sky at 200mb","W/m2")
+ CALL histdef2d(iff,flag_SWdn200,"SWdn200","SWdn at 200mb","W/m2" )
+ CALL histdef2d(iff,flag_SWdn200clr,"SWdn200clr","SWdn clear sky at 200mb","W/m2")
+ CALL histdef2d(iff,flag_LWup200,"LWup200","LWup at 200mb","W/m2") 
+ CALL histdef2d(iff,flag_LWup200clr, "LWup200clr","LWup clear sky at 200mb","W/m2")
+ CALL histdef2d(iff,flag_LWdn200,"LWdn200","LWdn at 200mb","W/m2") 
+ CALL histdef2d(iff,flag_LWdn200clr, "LWdn200clr","LWdn clear sky at 200mb","W/m2")
+ CALL histdef2d(iff,flag_sols,"sols","Solar rad. at surf.","W/m2")
+ CALL histdef2d(iff,flag_sols0,"sols0","Solar rad. at surf.","W/m2")
+ CALL histdef2d(iff,flag_soll,"soll","IR rad. at surface","W/m2")  
+ CALL histdef2d(iff,flag_radsol,"radsol","Rayonnement au sol","W/m2")
+ CALL histdef2d(iff,flag_soll0,"soll0","IR rad. at surface","W/m2") 
+ CALL histdef2d(iff,flag_SWupSFC,"SWupSFC","SWup at surface","W/m2")
+ CALL histdef2d(iff,flag_SWupSFCclr,"SWupSFCclr","SWup clear sky at surface","W/m2")
+ CALL histdef2d(iff,flag_SWdnSFC,"SWdnSFC","SWdn at surface","W/m2")
+ CALL histdef2d(iff,flag_SWdnSFCclr,"SWdnSFCclr","SWdn clear sky at surface","W/m2")
+ CALL histdef2d(iff,flag_LWupSFC,"LWupSFC","Upwd. IR rad. at surface","W/m2")
+ CALL histdef2d(iff,flag_LWdnSFC,"LWdnSFC","Down. IR rad. at surface","W/m2")
+ CALL histdef2d(iff,flag_LWupSFCclr,"LWupSFCclr","CS Upwd. IR rad. at surface","W/m2")
+ CALL histdef2d(iff,flag_LWdnSFCclr,"LWdnSFCclr","Down. CS IR rad. at surface","W/m2")
+ CALL histdef2d(iff,flag_bils,"bils","Surf. total heat flux","W/m2")
+ CALL histdef2d(iff,flag_sens,"sens","Sensible heat flux","W/m2")
+ CALL histdef2d(iff,flag_fder,"fder","Heat flux derivation","W/m2")
+ CALL histdef2d(iff,flag_ffonte,"ffonte","Thermal flux for snow melting","W/m2")
+ CALL histdef2d(iff,flag_fqcalving,"fqcalving","Ice Calving","kg/m2/s") 
+ CALL histdef2d(iff,flag_fqfonte,"fqfonte","Land ice melt","kg/m2/s") 
+
+     DO nsrf = 1, nbsrf
+ CALL histdef2d(iff,flag_pourc_sol,"pourc_"//clnsurf(nsrf),"% "//clnsurf(nsrf),"%")
+ CALL histdef2d(iff,flag_fract_sol,"fract_"//clnsurf(nsrf),"Fraction "//clnsurf(nsrf),"1")
+ CALL histdef2d(iff,flag_taux_sol,"taux_"//clnsurf(nsrf),"Zonal wind stress"//clnsurf(nsrf),"Pa")
+ CALL histdef2d(iff,flag_tauy_sol,"tauy_"//clnsurf(nsrf),"Meridional wind stress "//clnsurf(nsrf),"Pa")
+ CALL histdef2d(iff,flag_tsol_sol,"tsol_"//clnsurf(nsrf),"Temperature "//clnsurf(nsrf),"K")
+ CALL histdef2d(iff,flag_u10m_sol,"u10m_"//clnsurf(nsrf),"Vent Zonal 10m "//clnsurf(nsrf),"m/s")
+ CALL histdef2d(iff,flag_v10m_sol,"v10m_"//clnsurf(nsrf),"Vent meredien 10m "//clnsurf(nsrf),"m/s")
+ CALL histdef2d(iff,flag_t2m_sol,"t2m_"//clnsurf(nsrf),"Temp 2m "//clnsurf(nsrf),"K")
+ CALL histdef2d(iff,flag_sens_sol,"sens_"//clnsurf(nsrf),"Sensible heat flux "//clnsurf(nsrf),"W/m2")
+ CALL histdef2d(iff,flag_lat_sol,"lat_"//clnsurf(nsrf),"Latent heat flux "//clnsurf(nsrf),"W/m2")
+ CALL histdef2d(iff,flag_flw_sol,"flw_"//clnsurf(nsrf),"LW "//clnsurf(nsrf),"W/m2")
+ CALL histdef2d(iff,flag_fsw_sol,"fsw_"//clnsurf(nsrf),"SW "//clnsurf(nsrf),"W/m2")
+ CALL histdef2d(iff,flag_wbils_sol,"wbils_"//clnsurf(nsrf),"Bilan sol "//clnsurf(nsrf),"W/m2" )
+ CALL histdef2d(iff,flag_wbilo_sol,"wbilo_"//clnsurf(nsrf),"Bilan eau "//clnsurf(nsrf),"kg/(m2*s)")
+  if (iflag_pbl>1 .and. lev_files(iff).gt.10 ) then
+ CALL histdef2d(iff,flag_tke_sol,"tke_"//clnsurf(nsrf),"Max Turb. Kinetic Energy "//clnsurf(nsrf),"-")
+ CALL histdef2d(iff,flag_tke_max_sol,"tke_max_"//clnsurf(nsrf),"Max Turb. Kinetic Energy "//clnsurf(nsrf),"-")
+  endif
+ CALL histdef2d(iff,flag_albe_sol, "albe_"//clnsurf(nsrf),"Albedo surf. "//clnsurf(nsrf),"-")
+ CALL histdef2d(iff,flag_rugs_sol,"rugs_"//clnsurf(nsrf),"Latent heat flux "//clnsurf(nsrf),"W/m2")
+ CALL histdef2d(iff,flag_ages_sol,"ages_"//clnsurf(nsrf),"Snow age","day")
+     END DO
+
+ CALL histdef2d(iff,flag_albs,"albs","Surface albedo","-")
+ CALL histdef2d(iff,flag_albslw,"albslw","Surface albedo LW","-")
+ CALL histdef2d(iff,flag_cdrm,"cdrm","Momentum drag coef.", "-")
+ CALL histdef2d(iff,flag_cdrh,"cdrh","Heat drag coef.", "-" )
+ CALL histdef2d(iff,flag_cldl,"cldl","Low-level cloudiness", "-")
+ CALL histdef2d(iff,flag_cldm,"cldm","Mid-level cloudiness", "-")
+ CALL histdef2d(iff,flag_cldh,"cldh","High-level cloudiness", "-")
+ CALL histdef2d(iff,flag_cldt,"cldt","Total cloudiness","%")
+ CALL histdef2d(iff,flag_cldq,"cldq","Cloud liquid water path","kg/m2")
+ CALL histdef2d(iff,flag_lwp,"lwp","Cloud water path","kg/m2")
+ CALL histdef2d(iff,flag_iwp,"iwp","Cloud ice water path","kg/m2" )
+ CALL histdef2d(iff,flag_ue,"ue","Zonal energy transport","-")
+ CALL histdef2d(iff,flag_ve,"ve","Merid energy transport", "-")
+ CALL histdef2d(iff,flag_uq,"uq","Zonal humidity transport", "-")
+ CALL histdef2d(iff,flag_vq,"vq","Merid humidity transport", "-")
+
+     IF(iflag_con.GE.3) THEN ! sb
+ CALL histdef2d(iff,flag_cape,"cape","Conv avlbl pot ener","J/kg")
+ CALL histdef2d(iff,flag_pbase,"pbase","Cld base pressure", "mb")
+ CALL histdef2d(iff,flag_ptop,"ptop","Cld top pressure", "mb")
+ CALL histdef2d(iff,flag_fbase,"fbase","Cld base mass flux","kg/m2/s")
+ CALL histdef2d(iff,flag_prw,"prw","Precipitable water","kg/m2")
+     ENDIF !iflag_con .GE. 3
+
+ CALL histdef2d(iff,flag_s_pblh,"s_pblh","Boundary Layer Height","m")
+ CALL histdef2d(iff,flag_s_pblt,"s_pblt","t at Boundary Layer Height","K")
+ CALL histdef2d(iff,flag_s_lcl,"s_lcl","Condensation level","m")
+ CALL histdef2d(iff,flag_s_capCL,"s_capCL","Conv avlbl pot enerfor ABL", "J/m2" )
+ CALL histdef2d(iff,flag_s_oliqCL,"s_oliqCL","Liq Water in BL","kg/m2")
+ CALL histdef2d(iff,flag_s_cteiCL,"s_cteiCL","Instability criteria(ABL)","K")
+ CALL histdef2d(iff,flag_s_therm,"s_therm","Exces du thermique", "K")
+ CALL histdef2d(iff,flag_s_trmb1,"s_trmb1","deep_cape(HBTM2)","J/m2")
+ CALL histdef2d(iff,flag_s_trmb2,"s_trmb2","inhibition (HBTM2)","J/m2")
+ CALL histdef2d(iff,flag_s_trmb3,"s_trmb3","Point Omega (HBTM2)","m")
+
+! Champs interpolles sur des niveaux de pression
+! iif=1 on ecrit u v w phi sur 850 700 500 200 au niv 1
+! iif=2 on ecrit w et ph 500 seulement au niv 1
+!        et u v sur 850 700 500 200
+! iif=3 on ecrit ph a 500 seulement au niv 1
+!      on ecrit u v t q a 850 700 500 200 au niv 3
+
+        DO k=1, nlevSTD
+     IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+     IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+     IF(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200")THEN
+ CALL histdef2d(iff,flag_ulevsSTD,"u"//bb2,"Zonal wind "//bb2//"mb","m/s")
+ CALL histdef2d(iff,flag_vlevsSTD,"v"//bb2,"Meridional wind "//bb2//"mb","m/s")
+ CALL histdef2d(iff,flag_wlevsSTD,"w"//bb2,"Vertical wind "//bb2//"mb","m/s")
+ CALL histdef2d(iff,flag_philevsSTD,"phi"//bb2,"Geopotential "//bb2//"mb","m")
+ CALL histdef2d(iff,flag_qlevsSTD,"q"//bb2,"Specific humidity "//bb2//"mb","kg/kg" )
+ CALL histdef2d(iff,flag_tlevsSTD,"t"//bb2,"Temperature "//bb2//"mb","K")
+     ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+       ENDDO
+
+!IM diagnostiques flux ocean-atm ou ocean-glace de mer
+!IM pour utilisation dans un modele de "slab" ocean
+ CALL histdef2d(iff,flag_fluxo,"fluxo","Flux turbulents ocean-atmosphere","W/m2")
+ CALL histdef2d(iff,flag_fluxg,"fluxg","Flux turbulents ocean-glace de mer","W/m2")
+ CALL histdef2d(iff,flag_t_oce_sic,"t_oce_sic","Temp mixte oce-sic","K")
+
+     IF (OCEAN.EQ.'force ') THEN
+ CALL histdef2d(iff,flag_lmt_bils,"lmt_bils","Bilan au sol atmosphere forcee","W/m2")
+     ELSE IF (OCEAN.EQ.'slab  ') THEN
+ CALL histdef2d(iff,flag_slab_bils,"slab_bils","Bilan au sol Slab","W/m2") 
+ CALL histdef2d(iff,flag_tslab,"tslab", "Slab SST ", "K")
+ CALL histdef2d(iff,flag_seaice,"seaice","Slab seaice","kg/m2") 
+ CALL histdef2d(iff,flag_siceh,"siceh","Slab seaice height","m")
+     ENDIF
+
+ CALL histdef2d(iff,flag_ale_bl,"ale_bl","ALE BL","m2/s2") 
+ CALL histdef2d(iff,flag_alp_bl,"alp_bl","ALP BL","m2/s2") 
+ CALL histdef2d(iff,flag_ale_wk,"ale_wk","ALE WK","m2/s2") 
+ CALL histdef2d(iff,flag_alp_wk,"alp_wk","ALP WK","m2/s2") 
+
+ CALL histdef2d(iff,flag_ale,"ale","ALE","m2/s2")
+ CALL histdef2d(iff,flag_alp,"alp","ALP","W/m2")
+ CALL histdef2d(iff,flag_cin,"cin","Convective INhibition","m2/s2")
+ CALL histdef2d(iff,flag_wape,"WAPE","WAPE","m2/s2")
+
+ CALL histdef2d(iff,flag_weakinv, "weakinv","Weak inversion", "-")
+ CALL histdef2d(iff,flag_dthmin,"dthmin","dTheta mini", "K/m")
+ if (ok_isccp) then
+   CALL histdef2d(iff,flag_meantaucld,"meantaucld","ISCCP mean cloud optical thickness","1")
+ endif
+ CALL histdef2d(iff,flag_rh2m,"rh2m","Relative humidity at 2m", "%" )
+ CALL histdef2d(iff,flag_qsat2m,"qsat2m","Saturant humidity at 2m", "%")
+ CALL histdef2d(iff,flag_tpot,"tpot","Surface air potential temperature","K")
+ CALL histdef2d(iff,flag_tpote,"tpote","Surface air equivalent potential temperature","K")
+ CALL histdef2d(iff,flag_SWnetOR,"SWnetOR","Sfce net SW radiation OR", "W/m2")
+ CALL histdef2d(iff,flag_SWdownOR,"SWdownOR","Sfce incident SW radiation OR","W/m2")
+ CALL histdef2d(iff,flag_LWdownOR,"LWdownOR","Sfce incident LW radiation OR","W/m2")
+ CALL histdef2d(iff,flag_snowl,"snowl","Solid Large-scale Precip.","kg/(m2*s)")
+ CALL histdef2d(iff,flag_cape_max,"cape_max","CAPE max.", "J/kg")
+ CALL histdef2d(iff,flag_solldown,"solldown","Down. IR rad. at surface","W/m2")
+ CALL histdef2d(iff,flag_dtsvdfo,"dtsvdfo","Boundary-layer dTs(o)","K/s")
+ CALL histdef2d(iff,flag_dtsvdft,"dtsvdft","Boundary-layer dTs(t)","K/s")
+ CALL histdef2d(iff,flag_dtsvdfg,"dtsvdfg","Boundary-layer dTs(g)","K/s")
+ CALL histdef2d(iff,flag_dtsvdfi,"dtsvdfi","Boundary-layer dTs(g)","K/s")
+ CALL histdef2d(iff,flag_rugs,"rugs","rugosity", "-" )
+
+! Champs 3D:
+ CALL histdef3d(iff,flag_lwcon,"lwcon","Cloud liquid water content","kg/kg")
+ CALL histdef3d(iff,flag_iwcon,"iwcon","Cloud ice water content","kg/kg")
+ CALL histdef3d(iff,flag_temp,"temp","Air temperature","K" )
+ CALL histdef3d(iff,flag_theta,"theta","Potential air temperature","K" )
+ CALL histdef3d(iff,flag_ovap,"ovap","Specific humidity","kg/kg" )
+ CALL histdef3d(iff,flag_geop,"geop","Geopotential height","m2/s2")
+ CALL histdef3d(iff,flag_vitu,"vitu","Zonal wind", "m/s" )
+ CALL histdef3d(iff,flag_vitv,"vitv","Meridional wind","m/s" )
+ CALL histdef3d(iff,flag_vitw,"vitw","Vertical wind","m/s" )
+ CALL histdef3d(iff,flag_pres,"pres","Air pressure", "Pa" )
+ CALL histdef3d(iff,flag_rneb,"rneb","Cloud fraction","-")
+ CALL histdef3d(iff,flag_rnebcon,"rnebcon","Convective Cloud Fraction","-")
+ CALL histdef3d(iff,flag_rhum,"rhum","Relative humidity","-")
+ CALL histdef3d(iff,flag_ozone,"ozone","Ozone concentration", "ppmv")
+ CALL histdef3d(iff,flag_upwd,"upwd","saturated updraft", "kg/m2/s")
+ CALL histdef3d(iff,flag_dtphy,"dtphy","Physics dT","K/s")
+ CALL histdef3d(iff,flag_dqphy,"dqphy","Physics dQ", "(kg/kg)/s")
+ CALL histdef3d(iff,flag_cldtau,"cldtau","Cloud optical thickness","1")
+ CALL histdef3d(iff,flag_cldemi,"cldemi","Cloud optical emissivity","1")
+!IM: bug ?? dimensionnement variables (klon,klev+1) pmflxr, pmflxs, prfl, psfl
+! CALL histdef3d(iff,flag_pr_con_l,"pmflxr","Convective precipitation lic"," ")
+! CALL histdef3d(iff,flag_pr_con_i,"pmflxs","Convective precipitation ice"," ")
+! CALL histdef3d(iff,flag_pr_lsc_l,"prfl","Large scale precipitation lic"," ")
+! CALL histdef3d(iff,flag_pr_lsc_i,"psfl","Large scale precipitation ice"," ")
+
+!FH Sorties pour la couche limite
+     if (iflag_pbl>1) then
+ CALL histdef3d(iff,flag_tke,"tke","TKE","m2/s2")
+ CALL histdef3d(iff,flag_tke_max,"tke_max","TKE max","m2/s2")
+     endif
+
+ CALL histdef3d(iff,flag_kz,"kz","Kz melange","m2/s")
+ CALL histdef3d(iff,flag_kz_max,"kz_max","Kz melange max","m2/s" )
+ CALL histdef3d(iff,flag_clwcon,"clwcon","Convective Cloud Liquid water content", "kg/kg") 
+ CALL histdef3d(iff,flag_Ma,"Ma","undilute adiab updraft","kg/m2/s")
+ CALL histdef3d(iff,flag_dnwd,"dnwd","saturated downdraft","kg/m2/s")
+ CALL histdef3d(iff,flag_dnwd0,"dnwd0","unsat. downdraft", "kg/m2/s")
+ CALL histdef3d(iff,flag_dtdyn,"dtdyn","Dynamics dT","K/s")
+ CALL histdef3d(iff,flag_dqdyn,"dqdyn","Dynamics dQ", "(kg/kg)/s")
+ CALL histdef3d(iff,flag_dtcon,"dtcon","Convection dT","K/s")
+ CALL histdef3d(iff,flag_ducon,"ducon","Convection du","m/s2")
+ CALL histdef3d(iff,flag_dqcon,"dqcon","Convection dQ", "(kg/kg)/s")
+ IF (iflag_wake == 1) THEN
+   CALL histdef3d(iff,flag_dtwak,"dtwak","Wake dT","K/s")
+   CALL histdef3d(iff,flag_dqwak,"dqwak","Wake dQ","(kg/kg)/s")
+ endif
+ CALL histdef3d(iff,flag_dtlsc,"dtlsc","Condensation dT", "K/s")
+ CALL histdef3d(iff,flag_dtlschr,"dtlschr","Large-scale condensational heating rate","K/s")
+ CALL histdef3d(iff,flag_dqlsc,"dqlsc","Condensation dQ","(kg/kg)/s")
+ CALL histdef3d(iff,flag_dtvdf,"dtvdf","Boundary-layer dT", "K/s")
+ CALL histdef3d(iff,flag_dqvdf,"dqvdf","Boundary-layer dQ","(kg/kg)/s") 
+ CALL histdef3d(iff,flag_dteva,"dteva","Reevaporation dT", "K/s")
+ CALL histdef3d(iff,flag_dqeva,"dqeva","Reevaporation dQ","(kg/kg)/s")
+ CALL histdef3d(iff,flag_ptconv,"ptconv","POINTS CONVECTIFS"," ")
+ CALL histdef3d(iff,flag_ratqs,"ratqs", "RATQS"," ")
+ CALL histdef3d(iff,flag_dtthe,"dtthe","Dry adjust. dT", "K/s")
+ CALL histdef3d(iff,flag_f_th,"f_th","Thermal plume mass flux", "K/s")
+ CALL histdef3d(iff,flag_e_th,"e_th","Thermal plume entrainment", "K/s")
+ CALL histdef3d(iff,flag_d_th,"d_th","Thermal plume detrainment", "K/s")
+ CALL histdef2d(iff,flag_d_th,"f0_th","Thermal closure mass flux", "K/s")
+ CALL histdef2d(iff,flag_d_th,"zmax_th","Thermal plume height", "K/s")
+ CALL histdef3d(iff,flag_dqthe,"dqthe","Dry adjust. dQ","(kg/kg)/s")
+ CALL histdef3d(iff,flag_dtajs,"dtajs","Dry adjust. dT", "K/s")
+ CALL histdef3d(iff,flag_dqajs,"dqajs","Dry adjust. dQ","(kg/kg)/s")
+ CALL histdef3d(iff,flag_dtswr,"dtswr","SW radiation dT","K/s")
+ CALL histdef3d(iff,flag_dtsw0,"dtsw0","CS SW radiation dT","K/s")
+ CALL histdef3d(iff,flag_dtlwr,"dtlwr","LW radiation dT","K/s")
+ CALL histdef3d(iff,flag_dtlw0,"dtlw0", "CS LW radiation dT","K/s")
+ CALL histdef3d(iff,flag_dtec,"dtec","Cinetic dissip dT","K/s")
+ CALL histdef3d(iff,flag_duvdf,"duvdf","Boundary-layer dU","m/s2")
+ CALL histdef3d(iff,flag_dvvdf,"dvvdf","Boundary-layer dV", "m/s2")
+
+     IF (ok_orodr) THEN
+ CALL histdef3d(iff,flag_duoro,"duoro","Orography dU","m/s2")
+ CALL histdef3d(iff,flag_dvoro,"dvoro","Orography dV", "m/s2")
+     ENDIF
+
+     IF (ok_orolf) THEN
+ CALL histdef3d(iff,flag_dulif,"dulif","Orography dU","m/s2")
+ CALL histdef3d(iff,flag_dvlif,"dvlif","Orography dV", "m/s2")
+     ENDIF
+
+      if (nqmax>=3) THEN
+    DO iq=3,nqmax
+       iiq=niadv(iq)
+ CALL histdef3d ( iff, flag_trac, tnom(iq),ttext(iiq), "-" )
+    ENDDO
+      endif
+
+        CALL histend(nid_files(iff))
+
+         ndex2d = 0
+         ndex3d = 0
+
+         ENDIF ! clef_files
+
+         ENDDO ! 
+      end subroutine phys_output_open
+
+      SUBROUTINE histdef2d (iff,flag_var,nomvar,titrevar,unitvar)
+      
+       use ioipsl
+       USE dimphy
+       USE mod_phys_lmdz_para
+
+       IMPLICIT NONE
+       
+       include "dimensions.h"
+       include "temps.h"
+       include "indicesol.h"
+       include "advtrac.h"
+       include "clesphys.h"
+
+       integer                          :: iff
+       integer, dimension(nfiles)       :: flag_var
+       character(len=*)                 :: nomvar
+       character(len=*)                 :: titrevar
+       character(len=*)                 :: unitvar
+       
+       if ( flag_var(iff)<=lev_files(iff) ) then
+ call histdef (nid_files(iff),nomvar,titrevar,unitvar, &
+               iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
+               type_ecri(iff), zstophym(iff),zoutm(iff))                
+       endif                      
+      end subroutine histdef2d
+
+      SUBROUTINE histdef3d (iff,flag_var,nomvar,titrevar,unitvar)
+
+       use ioipsl
+       USE dimphy
+       USE mod_phys_lmdz_para
+
+       IMPLICIT NONE
+
+       include "dimensions.h"
+       include "temps.h"
+       include "indicesol.h"
+       include "advtrac.h"
+       include "clesphys.h"
+
+       integer                          :: iff
+       integer, dimension(nfiles)       :: flag_var
+       character(len=*)                 :: nomvar
+       character(len=*)                 :: titrevar
+       character(len=*)                 :: unitvar
+
+       if ( flag_var(iff)<=lev_files(iff) ) then
+ call histdef (nid_files(iff),nomvar,titrevar,unitvar, &
+               iim,jj_nb,nhorim(iff), klev,1,klev,nvertm(iff), 32, &
+               type_ecri(iff), zstophym(iff),zoutm(iff))
+       endif
+      end subroutine histdef3d
+
+END MODULE phys_output_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phys_output_write.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phys_output_write.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phys_output_write.h	(revision 984)
@@ -0,0 +1,1173 @@
+      itau_w = itau_phy + itap
+
+      DO iff=1,nfiles
+
+       IF (clef_files(iff)) THEN
+             ndex2d = 0
+             ndex3d = 0
+
+!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+       IF (flag_phis(iff)<=lev_files(iff)) THEN 
+         CALL histwrite_phy(nid_files(iff),
+     $                      "phis",itau_w,pphis)
+       ENDIF
+
+       IF (flag_aire(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"aire",itau_w,airephy)
+       ENDIF
+
+       IF (flag_pourc_sol(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+      CALL histwrite_phy(nid_files(iff),
+     $                   "pourc_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_fract_sol(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+      CALL histwrite_phy(nid_files(iff),
+     $               "fract_"//clnsurf(is_ter),itau_w,
+     $               zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_contfracATM(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),
+     $                   "contfracATM",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_contfracOR(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"contfracOR",itau_w,
+     $                   pctsrf_new(:,is_ter))
+       ENDIF
+
+       IF (flag_aireTER(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),
+     $                  "aireTER",itau_w,paire_ter)
+       ENDIF
+
+!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+       IF (flag_flat(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"flat",itau_w,zxfluxlat)
+       ENDIF
+
+       IF (flag_slp(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"slp",itau_w,slp)
+       ENDIF
+
+       IF (flag_tsol(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tsol",itau_w,zxtsol)
+       ENDIF
+
+       IF (flag_t2m(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"t2m",itau_w,zt2m)
+       ENDIF
+
+       IF (flag_t2m_min(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"t2m_min",itau_w,zt2m)
+       ENDIF
+
+       IF (flag_t2m_max(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"t2m_max",itau_w,zt2m)
+       ENDIF
+
+       IF (flag_wind10m(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"wind10m",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_wind10max(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"wind10max", 
+     $                   itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_sicf(iff)<=lev_files(iff)) THEN
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"sicf",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_q2m(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"q2m",itau_w,zq2m)
+       ENDIF
+
+       IF (flag_u10m(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"u10m",itau_w,zu10m)
+       ENDIF
+
+       IF (flag_v10m(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"v10m",itau_w,zv10m)
+       ENDIF
+
+       IF (flag_psol(iff)<=lev_files(iff)) THEN
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"psol",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_qsurf(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"qsurf",itau_w,zxqsurf)
+       ENDIF
+
+       if (.not. ok_veget) then
+         IF (flag_qsol(iff)<=lev_files(iff)) THEN
+        CALL histwrite_phy(nid_files(iff),"qsol",itau_w,qsol)
+         ENDIF
+       endif
+
+      IF (flag_precip(iff)<=lev_files(iff)) THEN
+       DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+       ENDDO
+      CALL histwrite_phy(nid_files(iff),"precip",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+       IF (flag_ndayrain(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"ndayrain",itau_w,nday_rain)
+       ENDIF
+
+      IF (flag_plul(iff)<=lev_files(iff)) THEN
+       DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+       ENDDO
+      CALL histwrite_phy(nid_files(iff),"plul",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_pluc(iff)<=lev_files(iff)) THEN
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"pluc",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+       IF (flag_snow(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"snow",itau_w,snow_fall)
+       ENDIF
+
+       IF (flag_evap(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"evap",itau_w,evap)
+       ENDIF
+
+       IF (flag_tops(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tops",itau_w,topsw)
+       ENDIF
+
+       IF (flag_tops0(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tops0",itau_w,topsw0)
+       ENDIF
+
+       IF (flag_topl(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"topl",itau_w,toplw)
+       ENDIF
+
+       IF (flag_topl0(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"topl0",itau_w,toplw0)
+       ENDIF
+
+       IF (flag_SWupTOA(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+      CALL histwrite_phy(nid_files(iff), "SWupTOA",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWupTOAclr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+      CALL histwrite_phy(nid_files(iff), 
+     $                  "SWupTOAclr",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWdnTOA(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+      CALL histwrite_phy(nid_files(iff), "SWdnTOA",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWdnTOAclr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+      CALL histwrite_phy(nid_files(iff), 
+     $                  "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWup200(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"SWup200",itau_w,SWup200)
+       ENDIF
+
+       IF (flag_SWup200clr(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"SWup200clr",itau_w,SWup200clr)
+       ENDIF
+
+       IF (flag_SWdn200(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"SWdn200",itau_w,SWdn200)
+       ENDIF
+
+       IF (flag_SWdn200clr(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"SWdn200clr",itau_w,SWdn200clr)
+       ENDIF
+
+       IF (flag_LWup200(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"LWup200",itau_w,LWup200)
+       ENDIF
+
+       IF (flag_LWup200clr(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"LWup200clr",itau_w,LWup200clr)
+       ENDIF
+
+       IF (flag_LWdn200(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"LWdn200",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_LWdn200clr(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"LWdn200clr",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_sols(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"sols",itau_w,solsw)
+       ENDIF
+
+       IF (flag_sols0(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"sols0",itau_w,solsw0)
+       ENDIF
+
+       IF (flag_soll(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"soll",itau_w,sollw)
+       ENDIF
+
+       IF (flag_radsol(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"radsol",itau_w,radsol)
+       ENDIF
+
+       IF (flag_soll0(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"soll0",itau_w,sollw0)
+       ENDIF
+
+       IF (flag_SWupSFC(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+      CALL histwrite_phy(nid_files(iff), "SWupSFC",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWupSFCclr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+      CALL histwrite_phy(nid_files(iff), 
+     $                   "SWupSFCclr",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWdnSFC(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+      CALL histwrite_phy(nid_files(iff), 
+     $                   "SWdnSFC",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_SWdnSFCclr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+      CALL histwrite_phy(nid_files(iff), 
+     $                  "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_LWupSFC(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+      CALL histwrite_phy(nid_files(iff),
+     $                    "LWupSFC",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_LWdnSFC(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),
+     $                   "LWdnSFC",itau_w,sollwdown)
+       ENDIF
+
+       sollwdownclr(1:klon) = -1.*lwdn0(1:klon,1)
+       IF (flag_LWupSFCclr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+      CALL histwrite_phy(nid_files(iff),
+     $                   "LWupSFCclr",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_LWdnSFCclr(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),
+     $                   "LWdnSFCclr",itau_w,sollwdownclr)
+       ENDIF
+
+       IF (flag_bils(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"bils",itau_w,bils)
+       ENDIF
+
+       IF (flag_sens(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+      CALL histwrite_phy(nid_files(iff),"sens",itau_w,zx_tmp_fi2d)
+       ENDIF
+
+       IF (flag_fder(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"fder",itau_w,fder)
+       ENDIF
+
+       IF (flag_ffonte(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"ffonte",itau_w,zxffonte)
+       ENDIF
+
+       IF (flag_fqcalving(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),
+     $                    "fqcalving",itau_w,zxfqcalving)
+       ENDIF
+
+       IF (flag_fqfonte(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),
+     $                    "fqfonte",itau_w,zxfqfonte)
+       ENDIF
+
+         DO nsrf = 1, nbsrf
+           IF(nsrf.GT.2) THEN
+            IF (flag_pourc_sol(iff)<=lev_files(iff)) THEN
+            zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+            CALL histwrite_phy(nid_files(iff),
+     $                     "pourc_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d)
+            ENDIF
+
+          IF (flag_fract_sol(iff)<=lev_files(iff)) THEN
+          zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+          CALL histwrite_phy(nid_files(iff),
+     $                    "fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+          ENDIF
+         ENDIF !nsrf.GT.2
+
+        IF (flag_taux_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                     "taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_tauy_sol(iff)<=lev_files(iff)) THEN           
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                    "tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_tsol_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                   "tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+      IF (flag_u10m_sol(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, nsrf)
+      CALL histwrite_phy(nid_files(iff),"u10m_"//clnsurf(nsrf),
+     $                 itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_v10m_sol(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, nsrf)
+      CALL histwrite_phy(nid_files(iff),"v10m_"//clnsurf(nsrf),
+     $              itau_w,zx_tmp_fi2d)
+      ENDIF
+ 
+      IF (flag_t2m_sol(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, nsrf)
+      CALL histwrite_phy(nid_files(iff),"t2m_"//clnsurf(nsrf),
+     $           itau_w,zx_tmp_fi2d)
+      ENDIF
+
+       IF (flag_sens_sol(iff)<=lev_files(iff)) THEN
+       zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+       CALL histwrite_phy(nid_files(iff),
+     $                     "sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDIF
+
+        IF (flag_lat_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                 "lat_"//clnsurf(nsrf),itau_w,
+     $                                   zx_tmp_fi2d)
+          ENDIF
+
+        IF (flag_flw_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                     "flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_fsw_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                     "fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_wbils_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                     "wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_wbilo_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),
+     $                    "wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+       if (iflag_pbl>1 .and. lev_histday.gt.10 ) then
+        IF (flag_tke_sol(iff)<=lev_files(iff)) THEN
+        CALL histwrite_phy(nid_files(iff),
+     $                    "tke_"//clnsurf(nsrf),itau_w,
+     $      pbl_tke(:,1:klev,nsrf))
+       ENDIF
+
+        IF (flag_tke_max_sol(iff)<=lev_files(iff)) THEN
+        CALL histwrite_phy(nid_files(iff),
+     $                    "tke_max_"//clnsurf(nsrf),itau_w,
+     $      pbl_tke(:,1:klev,nsrf))
+        ENDIF
+       endif
+      ENDDO
+
+        IF (flag_cdrm(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cdrm",itau_w,cdragm)
+        ENDIF
+
+        IF (flag_cdrh(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cdrh",itau_w,cdragh)
+        ENDIF
+
+        IF (flag_cldl(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cldl",itau_w,cldl)
+        ENDIF
+
+        IF (flag_cldm(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cldm",itau_w,cldm)
+        ENDIF
+
+        IF (flag_cldh(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cldh",itau_w,cldh)
+        ENDIF
+
+        IF (flag_cldt(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cldt", 
+     &                   itau_w,cldt*100)
+        ENDIF
+
+        IF (flag_cldq(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cldq",itau_w,cldq)
+        ENDIF
+
+        IF (flag_lwp(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+      CALL histwrite_phy(nid_files(iff),"lwp",itau_w,zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_iwp(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+      CALL histwrite_phy(nid_files(iff),"iwp",itau_w,zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_ue(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"ue",itau_w,ue)
+        ENDIF
+
+        IF (flag_ve(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"ve",itau_w,ve)
+        ENDIF
+
+        IF (flag_uq(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"uq",itau_w,uq)
+        ENDIF
+
+        IF (flag_vq(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"vq",itau_w,vq)
+        ENDIF
+
+      IF(iflag_con.GE.3) THEN ! sb
+        IF (flag_cape(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cape",itau_w,cape)
+        ENDIF
+
+        IF (flag_pbase(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"pbase",itau_w,pbase)
+        ENDIF
+
+        IF (flag_ptop(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"ptop",itau_w,ema_pct)
+        ENDIF
+
+        IF (flag_fbase(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"fbase",itau_w,ema_cbmf)
+        ENDIF
+
+        IF (flag_prw(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"prw",itau_w,prw)
+        ENDIF
+      ENDIF !iflag_con .GE. 3
+
+        IF (flag_s_pblh(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_pblh",itau_w,s_pblh)
+        ENDIF
+
+        IF (flag_s_pblt(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_pblt",itau_w,s_pblt)
+        ENDIF
+
+        IF (flag_s_lcl(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_lcl",itau_w,s_lcl)
+        ENDIF
+
+        IF (flag_s_capCL(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_capCL",itau_w,s_capCL)
+        ENDIF
+
+        IF (flag_s_oliqCL(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_oliqCL",itau_w,s_oliqCL)
+        ENDIF
+
+        IF (flag_s_cteiCL(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_cteiCL",itau_w,s_cteiCL)
+        ENDIF
+
+        IF (flag_s_therm(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_therm",itau_w,s_therm)
+        ENDIF
+
+        IF (flag_s_trmb1(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_trmb1",itau_w,s_trmb1)
+        ENDIF
+
+        IF (flag_s_trmb2(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_trmb2",itau_w,s_trmb2)
+        ENDIF
+
+        IF (flag_s_trmb3(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"s_trmb3",itau_w,s_trmb3)
+        ENDIF
+
+! Champs interpolles sur des niveaux de pression
+! if=1 on ecrit u v w phi sur 850 700 500 200 au niv 1
+! if=2 on ecrit w et ph 500 seulement au niv 1
+!        et u v sur 850 700 500 200
+! if=3 on ecrit ph a 500 seulement au niv 1
+!      on ecrit u v t q a 850 700 500 200 au niv 3
+
+        DO k=1, nlevSTD
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+         IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $      bb2.EQ."500".OR.bb2.EQ."200") THEN
+
+! a refaire correctement !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+       IF (flag_ulevsSTD(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"u"//bb2,  
+     & itau_w,ulevSTD(:,k))
+       ENDIF
+
+       IF (flag_vlevsSTD(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"v"//bb2,  
+     & itau_w,vlevSTD(:,k))
+       ENDIF
+
+       IF (flag_wlevsSTD(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"w"//bb2,  
+     & itau_w,wlevSTD(:,k))
+       ENDIF
+
+       IF (flag_philevsSTD(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),
+     $                  "phi"//bb2,  
+     &               itau_w,philevSTD(:,k))
+       ENDIF
+
+       IF (flag_qlevsSTD(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"q"//bb2,  
+     & itau_w, qlevSTD(:,k))
+       ENDIF
+
+       IF (flag_tlevsSTD(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"t"//bb2,  
+     & itau_w, tlevSTD(:,k))
+       ENDIF
+
+       ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+       ENDDO
+
+!IM diagnostiques flux ocean-atm ou ocean-glace de mer
+!IM pour utilisation dans un modele de "slab" ocean
+
+      IF (flag_fluxo(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"fluxo",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_fluxg(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"fluxg",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_t_oce_sic(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     $     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+
+     $                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     $                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"t_oce_sic",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (OCEAN.EQ.'force ') THEN
+      IF (flag_lmt_bils(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     $   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     $                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"lmt_bils",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (iflag_coupl.EQ.1) THEN
+       IF (flag_ale_bl(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"ale_bl",itau_w,ale_bl)
+       ENDIF
+       IF (flag_alp_bl(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"alp_bl",itau_w,alp_bl)
+       ENDIF
+      ENDIF !iflag_coupl.EQ.1
+
+      IF (iflag_wake.EQ.1) THEN
+       IF (flag_ale_wk(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"ale_wk",itau_w,ale_wake)
+       ENDIF
+       IF (flag_alp_wk(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"alp_wk",itau_w,alp_wake)
+       ENDIF
+
+       IF (flag_ale(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"ale",itau_w,ale)
+       ENDIF
+       IF (flag_alp(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"alp",itau_w,alp)
+       ENDIF
+       IF (flag_cin(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"cin",itau_w,cin)
+       ENDIF
+       IF (flag_wape(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"WAPE",itau_w,wake_pe)
+       ENDIF
+      ENDIF
+
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+
+      IF (flag_slab_bils(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     $   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     $                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"slab_bils",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_tslab(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+      CALL histwrite_phy(nid_files(iff),"tslab",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_seaice(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"seaice",itau_w,seaice)
+      ENDIF
+
+      IF (flag_siceh(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"siceh",itau_w, seaice/1000.)
+      ENDIF
+      ENDIF !OCEAN.EQ.force/slab
+
+      IF (flag_weakinv(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"weakinv",itau_w,weak_inversion)
+      ENDIF
+
+      IF (flag_dthmin(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dthmin",itau_w,dthmin)
+      ENDIF
+
+#ifdef histISCCP
+      IF(ok_isccp) THEN
+       IF (flag_meantaucld(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"meantaucld",itau_w,meantaucld)
+       ENDIF
+      ENDIF !(ok_isccp)
+#endif
+
+       IF (flag_cldtau(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"cldtau",itau_w,cldtau)
+       ENDIF
+
+       IF (flag_cldemi(iff)<=lev_files(iff)) THEN
+       CALL histwrite_phy(nid_files(iff),"cldemi",itau_w,cldemi)
+       ENDIF
+
+!      IF (flag_pr_con_l(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),"pmflxr",itau_w,pmflxr)
+!      ENDIF
+
+!      IF (flag_pr_con_i(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),"pmflxs",itau_w,pmflxs)
+!      ENDIF
+
+!      IF (flag_pr_lsc_l(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),"prfl",itau_w,prfl)
+!      ENDIF
+
+!      IF (flag_pr_lsc_i(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),"psfl",itau_w,psfl)
+!      ENDIF
+
+      IF (flag_rh2m(iff)<=lev_files(iff)) THEN
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+      CALL histwrite_phy(nid_files(iff),"rh2m",itau_w,zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_qsat2m(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"qsat2m",itau_w,qsat2m)
+      ENDIF
+
+      IF (flag_tpot(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tpot",itau_w,tpot)
+      ENDIF
+
+       IF (flag_tpote(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tpote",itau_w,tpote)
+       ENDIF
+
+      IF (flag_SWnetOR(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter)
+      CALL histwrite_phy(nid_files(iff),"SWnetOR",itau_w, zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_SWdownOR(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol1(1:klon))
+      CALL histwrite_phy(nid_files(iff),"SWdownOR",itau_w, zx_tmp_fi2d)
+      ENDIF
+
+      IF (flag_LWdownOR(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"LWdownOR",itau_w,sollwdown)
+      ENDIF
+
+      IF (flag_snowl(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"snowl",itau_w,snow_lsc)
+      ENDIF
+
+      IF (flag_cape_max(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"cape_max",itau_w,cape)
+      ENDIF
+
+      IF (flag_solldown(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"solldown",itau_w,sollwdown)
+      ENDIF
+
+      IF (flag_dtsvdfo(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dtsvdfo",itau_w,d_ts(:,is_oce))
+      ENDIF
+
+      IF (flag_dtsvdft(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dtsvdft",itau_w,d_ts(:,is_ter))
+      ENDIF
+
+       IF (flag_dtsvdfg(iff)<=lev_files(iff)) THEN
+        CALL histwrite_phy(nid_files(iff),
+     $                     "dtsvdfg",itau_w, d_ts(:,is_lic))
+       ENDIF
+
+       IF (flag_dtsvdfi(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dtsvdfi",itau_w,d_ts(:,is_sic))
+       ENDIF
+
+       IF (flag_rugs(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"rugs",itau_w,zxrugs)
+       ENDIF
+
+! Champs 3D:
+       IF (flag_lwcon(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"lwcon",itau_w,flwc)
+       ENDIF
+
+       IF (flag_iwcon(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"iwcon",itau_w,fiwc)
+       ENDIF
+
+       IF (flag_temp(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"temp",itau_w,t_seri)
+       ENDIF
+
+       IF (flag_theta(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"theta",itau_w,theta)
+       ENDIF
+
+       IF (flag_ovap(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"ovap",itau_w,qx(:,:,ivap))
+       ENDIF
+
+       IF (flag_geop(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"geop",itau_w,zphi)
+       ENDIF
+
+       IF (flag_vitu(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"vitu",itau_w,u_seri)
+       ENDIF
+
+       IF (flag_vitv(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"vitv",itau_w,v_seri)
+       ENDIF
+
+       IF (flag_vitw(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"vitw",itau_w,omega)
+       ENDIF
+
+        IF (flag_pres(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"pres",itau_w,pplay)
+        ENDIF
+
+       IF (flag_rneb(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"rneb",itau_w,cldfra)
+       ENDIF
+
+       IF (flag_rnebcon(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"rnebcon",itau_w,rnebcon)
+       ENDIF
+
+       IF (flag_rhum(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"rhum",itau_w,zx_rh)
+       ENDIF
+
+      IF (flag_ozone(iff)<=lev_files(iff)) THEN
+      DO k=1, klev
+       DO i=1, klon
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+      CALL histwrite_phy(nid_files(iff),"ozone",itau_w,zx_tmp_fi3d)
+      ENDIF
+
+       IF (flag_upwd(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"upwd",itau_w,upwd)
+       ENDIF
+
+       IF (flag_dtphy(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dtphy",itau_w,d_t)
+       ENDIF
+
+       IF (flag_dqphy(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dqphy",itau_w, d_qx(:,:,ivap))
+       ENDIF
+
+        DO nsrf=1, nbsrf
+        IF (flag_albe_sol(iff)<=lev_files(iff)) THEN 
+        zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_rugs_sol(iff)<=lev_files(iff)) THEN  
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+        ENDIF
+
+        IF (flag_ages_sol(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+        CALL histwrite_phy(nid_files(iff),"ages_"//clnsurf(nsrf),itau_w
+     $    ,zx_tmp_fi2d)
+        ENDIF
+        ENDDO !nsrf=1, nbsrf
+
+       IF (flag_albs(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"albs",itau_w,albsol1)
+       ENDIF
+
+       IF (flag_albslw(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"albslw",itau_w,albsol2)
+       ENDIF
+
+!FH Sorties pour la couche limite
+      if (iflag_pbl>1) then
+      zx_tmp_fi3d=0.
+      do nsrf=1,nbsrf
+         do k=1,klev
+          zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k)
+     $    +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+         enddo
+      enddo
+       IF (flag_tke(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tke",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_tke_max(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"tke_max",itau_w,zx_tmp_fi3d)
+       ENDIF
+      endif
+
+       IF (flag_kz(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"kz",itau_w,ycoefh)
+       ENDIF
+
+       IF (flag_kz_max(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"kz_max",itau_w,ycoefh)
+       ENDIF
+
+       IF (flag_clwcon(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"clwcon",itau_w,clwcon0)
+       ENDIF
+
+       IF (flag_Ma(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"Ma",itau_w,Ma)
+       ENDIF
+
+       IF (flag_dnwd(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dnwd",itau_w,dnwd)
+       ENDIF
+
+       IF (flag_dnwd0(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dnwd0",itau_w,dnwd0)
+       ENDIF
+
+       IF (flag_dtdyn(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dtdyn",itau_w,d_t_dyn)
+       ENDIF
+
+       IF (flag_dqdyn(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"dqdyn",itau_w,d_q_dyn)
+       ENDIF
+
+       IF (flag_dtcon(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dtcon",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_ducon(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"ducon",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dqcon(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dqcon",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (iflag_wake == 1) THEN
+         IF (flag_dtwak(iff)<=lev_files(iff)) THEN
+           zx_tmp_fi3d(1:klon,1:klev)=d_t_wake(1:klon,1:klev)           &
+     &                                        /pdtphys
+           CALL histwrite_phy(nid_files(iff),"dtwak",itau_w,zx_tmp_fi3d)
+         ENDIF
+
+        IF (flag_dqwak(iff)<=lev_files(iff)) THEN
+        zx_tmp_fi3d(1:klon,1:klev)=d_q_wake(1:klon,1:klev)/pdtphys
+        CALL histwrite_phy(nid_files(iff),"dqwak",itau_w,zx_tmp_fi3d)
+        ENDIF
+       ENDIF
+
+       IF (flag_dtlsc(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dtlsc",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtlschr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     $                           d_t_eva(1:klon,1:klev))/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dtlschr",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dqlsc(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dqlsc",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtvdf(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dtvdf",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dqvdf(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dqvdf",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dteva(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dteva",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dqeva(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dqeva",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_ptconv(iff)<=lev_files(iff)) THEN
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+      CALL histwrite_phy(nid_files(iff),"ptconv",itau_w,zpt_conv)
+       ENDIF
+
+       IF (flag_ratqs(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"ratqs",itau_w,ratqs)
+       ENDIF
+
+       IF (flag_dtthe(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dtthe",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (iflag_thermals.ge.1) THEN
+        IF (flag_f_th(iff)<=lev_files(iff)) THEN
+        CALL histwrite_phy(nid_files(iff),"f_th",itau_w,fm_therm)
+        ENDIF
+
+        IF (flag_e_th(iff)<=lev_files(iff)) THEN
+        CALL histwrite_phy(nid_files(iff),"e_th",itau_w,entr_therm)
+        ENDIF
+
+!       IF (flag_d_th(iff)<=lev_files(iff)) THEN
+!       CALL histwrite_phy(nid_files(iff),"d_th",itau_w,detr_therm)
+!       ENDIF
+       ENDIF !iflag_thermals
+
+       IF (flag_f0_th(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"f0_th",itau_w,f0)
+       ENDIF
+
+       IF (flag_f0_th(iff)<=lev_files(iff)) THEN
+      CALL histwrite_phy(nid_files(iff),"zmax_th",itau_w,zmax0)
+       ENDIF
+
+       IF (flag_dqthe(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dqthe",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtajs(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dtajs",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dqajs(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dqajs",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtswr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(nid_files(iff),"dtswr",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtsw0(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(nid_files(iff),"dtsw0",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtlwr(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(nid_files(iff),"dtlwr",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtlw0(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(nid_files(iff),"dtlw0",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dtec(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+      CALL histwrite_phy(nid_files(iff),"dtec",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_duvdf(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"duvdf",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (flag_dvvdf(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dvvdf",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+       IF (ok_orodr) THEN
+      IF (flag_duoro(iff)<=lev_files(iff)) THEN 
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"duoro",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+      IF (flag_dvoro(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dvoro",itau_w,zx_tmp_fi3d)
+      ENDIF
+       ENDIF
+
+        IF (ok_orolf) THEN
+       IF (flag_dulif(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dulif",itau_w,zx_tmp_fi3d)
+       ENDIF
+
+        IF (flag_dvlif(iff)<=lev_files(iff)) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(nid_files(iff),"dvlif",itau_w,zx_tmp_fi3d)
+       ENDIF
+        ENDIF
+
+       IF (flag_trac(iff)<=lev_files(iff)) THEN
+         if (nqmax.GE.3) THEN
+           DO iq=3,nqmax
+         CALL histwrite_phy(nid_files(iff),tnom(iq),itau_w,qx(:,:,iq))
+           ENDDO
+          endif
+
+       ENDIF
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_files(iff))
+c$OMP END MASTER
+      endif
+
+       ENDIF ! clef_files
+
+      ENDDO ! iff=1,nfiles
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phys_state_var_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phys_state_var_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phys_state_var_mod.F90	(revision 984)
@@ -0,0 +1,528 @@
+      MODULE phys_state_var_mod
+! Variables sauvegardees pour le startphy.nc
+!======================================================================
+!
+!
+!======================================================================
+! Declaration des variables
+      USE dimphy
+      INTEGER, PARAMETER :: nlevSTD=17
+      INTEGER, PARAMETER :: nout=3
+      INTEGER, PARAMETER :: napisccp=1
+      INTEGER, SAVE :: radpas
+      REAL, SAVE :: dtime, co2_ppm_etat0, solaire_etat0
+!$OMP THREADPRIVATE(radpas)
+!$OMP THREADPRIVATE(dtime, co2_ppm_etat0, solaire_etat0)
+
+      REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:), pctsrf(:,:)
+!$OMP THREADPRIVATE(rlat, rlon, pctsrf)
+      REAL, ALLOCATABLE, SAVE :: ftsol(:,:)
+!$OMP THREADPRIVATE(ftsol)
+!      character(len=6), SAVE :: ocean
+!!!!!!$OMP THREADPRIVATE(ocean)
+!      logical, SAVE :: ok_veget 
+!!!!!!$OMP THREADPRIVATE(ok_veget)
+      REAL, ALLOCATABLE, SAVE :: falb1(:,:), falb2(:,:)
+!$OMP THREADPRIVATE(falb1, falb2)
+      REAL, ALLOCATABLE, SAVE :: rain_fall(:), snow_fall(:)
+!$OMP THREADPRIVATE( rain_fall, snow_fall)
+      REAL, ALLOCATABLE, SAVE :: solsw(:), sollw(:)
+!$OMP THREADPRIVATE(solsw, sollw)
+      REAL, ALLOCATABLE, SAVE :: radsol(:)
+!$OMP THREADPRIVATE(radsol)
+
+!clesphy0 param physiq
+!
+! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
+!
+      REAL, ALLOCATABLE, SAVE :: zmea(:), zstd(:), zsig(:), zgam(:)
+!$OMP THREADPRIVATE(zmea, zstd, zsig, zgam)
+      REAL, ALLOCATABLE, SAVE :: zthe(:), zpic(:), zval(:)
+!$OMP THREADPRIVATE(zthe, zpic, zval)
+!     REAL tabcntr0(100)
+      REAL, ALLOCATABLE, SAVE :: rugoro(:)
+!$OMP THREADPRIVATE(rugoro)
+      REAL, ALLOCATABLE, SAVE :: t_ancien(:,:), q_ancien(:,:)
+!$OMP THREADPRIVATE(t_ancien, q_ancien)
+      LOGICAL, SAVE :: ancien_ok
+!$OMP THREADPRIVATE(ancien_ok)
+      REAL, ALLOCATABLE, SAVE :: clwcon(:,:),rnebcon(:,:)
+!$OMP THREADPRIVATE(clwcon,rnebcon)
+      REAL, ALLOCATABLE, SAVE :: ratqs(:,:)
+!$OMP THREADPRIVATE(ratqs)
+      REAL, ALLOCATABLE, SAVE :: pbl_tke(:,:,:) ! turb kinetic energy
+!$OMP THREADPRIVATE(pbl_tke)
+      REAL, ALLOCATABLE, SAVE :: zmax0(:), f0(:) ! 
+!$OMP THREADPRIVATE(zmax0,f0)
+      REAL, ALLOCATABLE, SAVE :: ema_work1(:,:), ema_work2(:,:)
+!$OMP THREADPRIVATE(ema_work1,ema_work2)
+      REAL, ALLOCATABLE, SAVE :: entr_therm(:,:), fm_therm(:,:)
+!$OMP THREADPRIVATE(entr_therm,fm_therm)
+      REAL, ALLOCATABLE, SAVE :: detr_therm(:,:)
+!$OMP THREADPRIVATE(detr_therm)
+!IM 150408
+!     pour phsystoke avec thermiques
+      REAL,ALLOCATABLE,SAVE :: clwcon0th(:,:),rnebcon0th(:,:)
+!$OMP THREADPRIVATE(clwcon0th,rnebcon0th)
+! radiation outputs
+      REAL,ALLOCATABLE,SAVE :: swdn0(:,:), swdn(:,:)
+!$OMP THREADPRIVATE(swdn0,swdn)
+      REAL,ALLOCATABLE,SAVE :: swup0(:,:), swup(:,:)
+!$OMP THREADPRIVATE(swup0,swup)
+      REAL,ALLOCATABLE,SAVE :: SWdn200clr(:), SWdn200(:)
+!$OMP THREADPRIVATE(SWdn200clr,SWdn200)
+      REAL,ALLOCATABLE,SAVE :: SWup200clr(:), SWup200(:)
+!$OMP THREADPRIVATE(SWup200clr,SWup200)
+      REAL,ALLOCATABLE,SAVE :: lwdn0(:,:), lwdn(:,:)
+!$OMP THREADPRIVATE(lwdn0,lwdn)
+      REAL,ALLOCATABLE,SAVE :: lwup0(:,:), lwup(:,:)
+!$OMP THREADPRIVATE(lwup0,lwup)
+      REAL,ALLOCATABLE,SAVE :: LWdn200clr(:), LWdn200(:)
+!$OMP THREADPRIVATE(LWdn200clr,LWdn200)
+      REAL,ALLOCATABLE,SAVE :: LWup200clr(:), LWup200(:)
+!$OMP THREADPRIVATE(LWup200clr,LWup200)
+      REAL,ALLOCATABLE,SAVE :: LWdnTOA(:), LWdnTOAclr(:)
+!$OMP THREADPRIVATE(LWdnTOA,LWdnTOAclr)
+! pressure level
+      REAL,ALLOCATABLE,SAVE :: tsumSTD(:,:,:)
+!$OMP THREADPRIVATE(tsumSTD)
+      REAL,ALLOCATABLE,SAVE :: usumSTD(:,:,:), vsumSTD(:,:,:)
+!$OMP THREADPRIVATE(usumSTD,vsumSTD)
+      REAL,ALLOCATABLE,SAVE :: wsumSTD(:,:,:), phisumSTD(:,:,:)
+!$OMP THREADPRIVATE(wsumSTD,phisumSTD)
+      REAL,ALLOCATABLE,SAVE :: qsumSTD(:,:,:), rhsumSTD(:,:,:)
+!$OMP THREADPRIVATE(qsumSTD,rhsumSTD)
+      REAL,ALLOCATABLE,SAVE :: tnondef(:,:,:) 
+!$OMP THREADPRIVATE(tnondef)
+      REAL,ALLOCATABLE,SAVE :: uvsumSTD(:,:,:)
+!$OMP THREADPRIVATE(uvsumSTD)
+      REAL,ALLOCATABLE,SAVE :: vqsumSTD(:,:,:)
+!$OMP THREADPRIVATE(vqsumSTD)
+      REAL,ALLOCATABLE,SAVE :: vTsumSTD(:,:,:)
+!$OMP THREADPRIVATE(vTsumSTD)
+      REAL,ALLOCATABLE,SAVE :: wqsumSTD(:,:,:)
+!$OMP THREADPRIVATE(wqsumSTD)
+      REAL,ALLOCATABLE,SAVE :: vphisumSTD(:,:,:)
+!$OMP THREADPRIVATE(vphisumSTD)
+      REAL,ALLOCATABLE,SAVE :: wTsumSTD(:,:,:)
+!$OMP THREADPRIVATE(wTsumSTD)
+      REAL,ALLOCATABLE,SAVE :: u2sumSTD(:,:,:)
+!$OMP THREADPRIVATE(u2sumSTD)
+      REAL,ALLOCATABLE,SAVE :: v2sumSTD(:,:,:)
+!$OMP THREADPRIVATE(v2sumSTD)
+      REAL,ALLOCATABLE,SAVE :: T2sumSTD(:,:,:)
+!$OMP THREADPRIVATE(T2sumSTD)
+      INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:)
+!$OMP THREADPRIVATE(seed_old)
+      REAL,ALLOCATABLE,SAVE :: zuthe(:),zvthe(:)
+!$OMP THREADPRIVATE(zuthe,zvthe)
+      REAL,ALLOCATABLE,SAVE :: alb_neig(:)
+!$OMP THREADPRIVATE(alb_neig)
+!cloud base mass flux
+      REAL,ALLOCATABLE,SAVE :: ema_workcbmf(:), ema_cbmf(:)
+!$OMP THREADPRIVATE(ema_workcbmf,ema_cbmf)
+!cloud base pressure & cloud top pressure
+      REAL,ALLOCATABLE,SAVE :: ema_pcb(:), ema_pct(:)
+!$OMP THREADPRIVATE(ema_pcb,ema_pct)
+      REAL,ALLOCATABLE,SAVE :: Ma(:,:)        ! undilute upward mass flux
+!$OMP THREADPRIVATE(Ma)
+      REAL,ALLOCATABLE,SAVE :: qcondc(:,:)    ! in-cld water content from convect
+!$OMP THREADPRIVATE(qcondc)
+      REAL,ALLOCATABLE,SAVE :: wd(:) ! sb
+!$OMP THREADPRIVATE(wd)
+      REAL,ALLOCATABLE,SAVE :: sigd(:)
+!$OMP THREADPRIVATE(sigd)
+!
+      REAL,ALLOCATABLE,SAVE :: cin(:)
+!$OMP THREADPRIVATE(cin)
+! ftd : differential heating between wake and environment
+      REAL,ALLOCATABLE,SAVE :: ftd(:,:)
+!$OMP THREADPRIVATE(ftd)
+! fqd : differential moistening between wake and environment
+      REAL,ALLOCATABLE,SAVE :: fqd(:,:)     
+!$OMP THREADPRIVATE(fqd)
+!34EK
+! -- Variables de controle de ALE et ALP
+!ALE : Energie disponible pour soulevement : utilisee par la 
+!      convection d'Emanuel pour le declenchement et la regulation
+      REAL,ALLOCATABLE,SAVE :: ALE(:)
+!$OMP THREADPRIVATE(ALE)
+!ALP : Puissance  disponible pour soulevement
+      REAL,ALLOCATABLE,SAVE :: ALP(:)
+!$OMP THREADPRIVATE(ALP)
+!
+! nouvelles variables pour le couplage convection-couche limite
+      REAL,ALLOCATABLE,SAVE :: Ale_bl(:)
+!$OMP THREADPRIVATE(Ale_bl)
+      REAL,ALLOCATABLE,SAVE :: Alp_bl(:)
+!$OMP THREADPRIVATE(Alp_bl)
+      INTEGER,ALLOCATABLE,SAVE :: lalim_conv(:)
+!$OMP THREADPRIVATE(lalim_conv)
+      REAL,ALLOCATABLE,SAVE :: wght_th(:,:)
+!$OMP THREADPRIVATE(wght_th)
+!
+! variables de la wake
+! wake_deltat : ecart de temperature avec la zone non perturbee
+! wake_deltaq : ecart d'humidite avec la zone non perturbee
+! wake_Cstar  : vitesse d'etalement de la poche
+! wake_s      : fraction surfacique occupee par la poche froide
+! wake_fip    : Gust Front Impinging power - ALP
+! dt_wake, dq_wake: LS tendencies due to wake
+      REAL,ALLOCATABLE,SAVE :: wake_deltat(:,:)
+!$OMP THREADPRIVATE(wake_deltat)
+      REAL,ALLOCATABLE,SAVE :: wake_deltaq(:,:)
+!$OMP THREADPRIVATE(wake_deltaq)
+      REAL,ALLOCATABLE,SAVE :: wake_Cstar(:)
+!$OMP THREADPRIVATE(wake_Cstar)
+      REAL,ALLOCATABLE,SAVE :: wake_s(:)
+!$OMP THREADPRIVATE(wake_s)
+      REAL,ALLOCATABLE,SAVE :: wake_fip(:)
+!$OMP THREADPRIVATE(wake_fip)
+      REAL,ALLOCATABLE,SAVE :: dt_wake(:,:)
+!$OMP THREADPRIVATE(dt_wake)
+      REAL,ALLOCATABLE,SAVE :: dq_wake(:,:)
+!$OMP THREADPRIVATE(dq_wake)
+!
+! pfrac_impa : Produits des coefs lessivage impaction
+! pfrac_nucl : Produits des coefs lessivage nucleation
+! pfrac_1nucl: Produits des coefs lessi nucl (alpha = 1) 
+      REAL,ALLOCATABLE,SAVE :: pfrac_impa(:,:), pfrac_nucl(:,:)
+!$OMP THREADPRIVATE(pfrac_impa,pfrac_nucl)
+      REAL,ALLOCATABLE,SAVE :: pfrac_1nucl(:,:)
+!$OMP THREADPRIVATE(pfrac_1nucl)
+!
+      REAL,ALLOCATABLE,SAVE :: total_rain(:), nday_rain(:)  
+!$OMP THREADPRIVATE(total_rain,nday_rain)
+      REAL,ALLOCATABLE,SAVE :: paire_ter(:)
+!$OMP THREADPRIVATE(paire_ter)
+! albsol1: albedo du sol total pour SW visible
+! albsol2: albedo du sol total pour SW proche IR
+      REAL,ALLOCATABLE,SAVE :: albsol1(:), albsol2(:)
+!$OMP THREADPRIVATE(albsol1,albsol2)
+      REAL,ALLOCATABLE,SAVE :: wo(:,:)
+!$OMP THREADPRIVATE(wo)
+!
+! heat : chauffage solaire
+! heat0: chauffage solaire ciel clair
+! cool : refroidissement infrarouge
+! cool0 : refroidissement infrarouge ciel clair
+! sollwdown : downward LW flux at surface
+! sollwdownclr : downward CS LW flux at surface
+! toplwdown : downward CS LW flux at TOA
+! toplwdownclr : downward CS LW flux at TOA
+      REAL,ALLOCATABLE,SAVE :: clwcon0(:,:),rnebcon0(:,:)
+!$OMP THREADPRIVATE(clwcon0,rnebcon0)
+      REAL,ALLOCATABLE,SAVE :: heat(:,:)   
+!$OMP THREADPRIVATE(heat)
+      REAL,ALLOCATABLE,SAVE :: heat0(:,:)
+!$OMP THREADPRIVATE(heat0)
+      REAL,ALLOCATABLE,SAVE :: cool(:,:)
+!$OMP THREADPRIVATE(cool)
+      REAL,ALLOCATABLE,SAVE :: cool0(:,:)
+!$OMP THREADPRIVATE(cool0)
+      REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:)
+!$OMP THREADPRIVATE(topsw,toplw)
+      REAL,ALLOCATABLE,SAVE :: sollwdown(:)
+!$OMP THREADPRIVATE(sollwdown)
+      REAL,ALLOCATABLE,SAVE :: sollwdownclr(:)
+!$OMP THREADPRIVATE(sollwdownclr)
+      REAL,ALLOCATABLE,SAVE :: toplwdown(:)
+!$OMP THREADPRIVATE(toplwdown)
+      REAL,ALLOCATABLE,SAVE :: toplwdownclr(:)
+!$OMP THREADPRIVATE(toplwdownclr)
+      REAL,ALLOCATABLE,SAVE :: topsw0(:),toplw0(:),solsw0(:),sollw0(:)
+!$OMP THREADPRIVATE(topsw0,toplw0,solsw0,sollw0)
+      REAL,ALLOCATABLE,SAVE :: albpla(:)
+!$OMP THREADPRIVATE(albpla)
+! pbase : cloud base pressure
+! bbase : cloud base buoyancy
+      REAL,ALLOCATABLE,SAVE :: cape(:)
+!$OMP THREADPRIVATE(cape)
+      REAL,ALLOCATABLE,SAVE :: pbase(:)
+!$OMP THREADPRIVATE(pbase)
+      REAL,ALLOCATABLE,SAVE :: bbase(:)
+!$OMP THREADPRIVATE(bbase)
+!
+      REAL,SAVE,ALLOCATABLE :: zqasc(:,:)
+!$OMP THREADPRIVATE( zqasc)
+      INTEGER,ALLOCATABLE,SAVE :: ibas_con(:), itop_con(:)
+!$OMP THREADPRIVATE(ibas_con,itop_con)
+      REAL,SAVE,ALLOCATABLE :: rain_con(:)
+!$OMP THREADPRIVATE(rain_con)
+      REAL,SAVE,ALLOCATABLE :: snow_con(:)
+!$OMP THREADPRIVATE(snow_con)
+!
+! sulfate_pi : SO4 aerosol concentration [ug/m3] (pre-industrial value)
+
+      REAL,SAVE,ALLOCATABLE :: sulfate_pi(:, :)
+!$OMP THREADPRIVATE(sulfate_pi)
+      REAL,SAVE,ALLOCATABLE :: rlonPOS(:)
+!$OMP THREADPRIVATE(rlonPOS)
+      REAL,SAVE,ALLOCATABLE :: newsst(:)
+!$OMP THREADPRIVATE(newsst)
+      REAL,SAVE,ALLOCATABLE :: u10m(:,:), v10m(:,:)
+!$OMP THREADPRIVATE(u10m,v10m)
+!
+! ok_ade=T -ADE=topswad-topsw
+! ok_aie=T ->
+!       ok_ade=T -AIE=topswai-topswad
+!        ok_ade=F -AIE=topswai-topsw
+!
+!topswad, solswad : Aerosol direct effect
+      REAL,SAVE,ALLOCATABLE :: topswad(:), solswad(:)
+!$OMP THREADPRIVATE(topswad,solswad)
+!topswai, solswai : Aerosol indirect effect
+      REAL,SAVE,ALLOCATABLE :: topswai(:), solswai(:)
+!$OMP THREADPRIVATE(topswai,solswai)
+      REAL,SAVE,ALLOCATABLE :: tau_ae(:,:,:), piz_ae(:,:,:)
+!$OMP THREADPRIVATE(tau_ae,piz_ae)
+      REAL,SAVE,ALLOCATABLE :: cg_ae(:,:,:)
+!$OMP THREADPRIVATE(cg_ae)
+
+! Les variables suivants uniquement pour un configuration avec INCA
+! topswad_inca, solswad_inca : Aerosol direct effect
+      REAL,SAVE,ALLOCATABLE :: topswad_inca(:), solswad_inca(:)
+!$OMP THREADPRIVATE(topswad_inca,solswad_inca)
+! topswad0_inca, solswad0_inca : Aerosol direct effect
+      REAL,SAVE,ALLOCATABLE :: topswad0_inca(:), solswad0_inca(:)
+!$OMP THREADPRIVATE(topswad0_inca,solswad0_inca)
+! topswai_inca, solswai_inca : Aerosol indirect effect
+      REAL,SAVE,ALLOCATABLE :: topswai_inca(:), solswai_inca(:)
+!$OMP THREADPRIVATE(topswai_inca,solswai_inca)
+      REAL,SAVE,ALLOCATABLE :: topsw_inca(:,:), solsw_inca(:,:)
+!$OMP THREADPRIVATE(topsw_inca,solsw_inca)
+      REAL,SAVE,ALLOCATABLE :: topsw0_inca(:,:), solsw0_inca(:,:)
+!$OMP THREADPRIVATE(topsw0_inca,solsw0_inca)
+      REAL,SAVE,ALLOCATABLE :: tau_inca(:,:,:,:)
+!$OMP THREADPRIVATE(tau_inca)
+      REAL,SAVE,ALLOCATABLE :: piz_inca(:,:,:,:)
+!$OMP THREADPRIVATE(piz_inca)
+      REAL,SAVE,ALLOCATABLE :: cg_inca(:,:,:,:)
+!$OMP THREADPRIVATE(cg_inca)
+      REAL,SAVE,ALLOCATABLE :: ccm(:,:,:)
+!$OMP THREADPRIVATE(ccm)
+
+CONTAINS
+
+!======================================================================
+SUBROUTINE phys_state_var_init
+use dimphy
+IMPLICIT NONE
+#include "indicesol.h"
+#include "control.h"
+      ALLOCATE(rlat(klon), rlon(klon))
+      ALLOCATE(pctsrf(klon,nbsrf))
+      ALLOCATE(ftsol(klon,nbsrf))
+      ALLOCATE(falb1(klon,nbsrf))
+      ALLOCATE(falb2(klon,nbsrf))
+      ALLOCATE(rain_fall(klon))
+      ALLOCATE(snow_fall(klon))
+      ALLOCATE(solsw(klon), sollw(klon))
+      ALLOCATE(radsol(klon))
+      ALLOCATE(zmea(klon), zstd(klon), zsig(klon), zgam(klon))
+      ALLOCATE(zthe(klon), zpic(klon), zval(klon))
+
+      ALLOCATE(rugoro(klon))
+      ALLOCATE(t_ancien(klon,klev), q_ancien(klon,klev))
+      ALLOCATE(clwcon(klon,klev),rnebcon(klon,klev))
+      ALLOCATE(ratqs(klon,klev))
+      ALLOCATE(pbl_tke(klon,klev+1,nbsrf))
+      ALLOCATE(zmax0(klon), f0(klon))
+      ALLOCATE(ema_work1(klon,klev), ema_work2(klon,klev))
+      ALLOCATE(entr_therm(klon,klev), fm_therm(klon,klev+1))
+      ALLOCATE(detr_therm(klon,klev))
+!     pour phsystoke avec thermiques
+      ALLOCATE(clwcon0th(klon,klev),rnebcon0th(klon,klev))
+! radiation outputs
+      ALLOCATE(swdn0(klon,klevp1), swdn(klon,klevp1))
+      ALLOCATE(swup0(klon,klevp1), swup(klon,klevp1))
+      ALLOCATE(lwdn0(klon,klevp1), lwdn(klon,klevp1))
+      ALLOCATE(lwup0(klon,klevp1), lwup(klon,klevp1))
+      ALLOCATE(SWdn200clr(klon), SWdn200(klon))
+      ALLOCATE(SWup200clr(klon), SWup200(klon))
+      ALLOCATE(LWdn200clr(klon), LWdn200(klon))
+      ALLOCATE(LWup200clr(klon), LWup200(klon))
+      ALLOCATE(LWdnTOA(klon), LWdnTOAclr(klon))
+! pressure level
+      ALLOCATE(tsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(usumSTD(klon,nlevSTD,nout), vsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(wsumSTD(klon,nlevSTD,nout), phisumSTD(klon,nlevSTD,nout))
+      ALLOCATE(qsumSTD(klon,nlevSTD,nout), rhsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(tnondef(klon,nlevSTD,nout))
+      ALLOCATE(uvsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(vqsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(vTsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(wqsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(vphisumSTD(klon,nlevSTD,nout))
+      ALLOCATE(wTsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(u2sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(v2sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(T2sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(seed_old(klon,napisccp))
+      ALLOCATE(zuthe(klon),zvthe(klon))
+      ALLOCATE(alb_neig(klon))
+!cloud base mass flux
+      ALLOCATE(ema_workcbmf(klon), ema_cbmf(klon))
+!cloud base pressure & cloud top pressure
+      ALLOCATE(ema_pcb(klon), ema_pct(klon))
+!
+      ALLOCATE(Ma(klon,klev))
+      ALLOCATE(qcondc(klon,klev))
+      ALLOCATE(wd(klon))
+      ALLOCATE(sigd(klon))
+      ALLOCATE(cin(klon), ALE(klon), ALP(klon))
+      ALLOCATE(ftd(klon,klev), fqd(klon,klev))
+      ALLOCATE(Ale_bl(klon))
+      ALLOCATE(Alp_bl(klon))
+      ALLOCATE(lalim_conv(klon))
+      ALLOCATE(wght_th(klon,klev))
+      ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev))
+      ALLOCATE(wake_Cstar(klon), wake_s(klon), wake_fip(klon))
+      ALLOCATE(dt_wake(klon,klev), dq_wake(klon,klev))
+      ALLOCATE(pfrac_impa(klon,klev), pfrac_nucl(klon,klev))
+      ALLOCATE(pfrac_1nucl(klon,klev))
+      ALLOCATE(total_rain(klon), nday_rain(klon))
+      ALLOCATE(paire_ter(klon))
+      ALLOCATE(albsol1(klon), albsol2(klon))
+      ALLOCATE(wo(klon,klev))
+      ALLOCATE(clwcon0(klon,klev),rnebcon0(klon,klev))
+      ALLOCATE(heat(klon,klev), heat0(klon,klev)) 
+      ALLOCATE(cool(klon,klev), cool0(klon,klev))
+      ALLOCATE(topsw(klon), toplw(klon))
+      ALLOCATE(sollwdown(klon), sollwdownclr(klon))
+      ALLOCATE(toplwdown(klon), toplwdownclr(klon))
+      ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon))
+      ALLOCATE(albpla(klon))
+      ALLOCATE(cape(klon))
+      ALLOCATE(pbase(klon),bbase(klon))
+      ALLOCATE(zqasc(klon,klev))
+      ALLOCATE(ibas_con(klon), itop_con(klon))
+      ALLOCATE(rain_con(klon), snow_con(klon))
+!
+      ALLOCATE(sulfate_pi(klon, klev))
+      ALLOCATE(rlonPOS(klon))
+      ALLOCATE(newsst(klon))
+      ALLOCATE(u10m(klon,nbsrf), v10m(klon,nbsrf))
+      ALLOCATE(topswad(klon), solswad(klon))
+      ALLOCATE(topswai(klon), solswai(klon))
+      ALLOCATE(tau_ae(klon,klev,2), piz_ae(klon,klev,2))
+      ALLOCATE(cg_ae(klon,klev,2))
+
+      IF (config_inca /= 'none') THEN
+         ALLOCATE(topswad_inca(klon), solswad_inca(klon))
+         ALLOCATE(topswad0_inca(klon), solswad0_inca(klon))
+         ALLOCATE(topswai_inca(klon), solswai_inca(klon))
+         ALLOCATE(topsw_inca(klon,9), solsw_inca(klon,9))
+         ALLOCATE(topsw0_inca(klon,9), solsw0_inca(klon,9))
+      END IF
+      ! Following 4 variables are needed only by INCA but must be
+      ! allocated as they exist in the phytrac argument list
+      ALLOCATE(tau_inca(klon,klev,9,2))
+      ALLOCATE(piz_inca(klon,klev,9,2))
+      ALLOCATE(cg_inca(klon,klev,9,2))
+      ALLOCATE(ccm(klon,klev,2))
+
+END SUBROUTINE phys_state_var_init
+
+!======================================================================
+SUBROUTINE phys_state_var_end
+use dimphy
+IMPLICIT NONE
+#include "indicesol.h"
+#include "control.h"
+
+      deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2)
+      deallocate(rain_fall, snow_fall, solsw, sollw, radsol)
+      deallocate(zmea, zstd, zsig, zgam)
+      deallocate(zthe, zpic, zval)
+      deallocate(rugoro, t_ancien, q_ancien, clwcon, rnebcon)
+      deallocate(ratqs, pbl_tke)
+      deallocate(zmax0, f0)
+      deallocate(ema_work1, ema_work2)
+      deallocate(entr_therm, fm_therm)
+      deallocate(detr_therm)
+      deallocate(clwcon0th, rnebcon0th)
+! radiation outputs
+      deallocate(swdn0, swdn)
+      deallocate(swup0, swup)
+      deallocate(lwdn0, lwdn)
+      deallocate(lwup0, lwup)
+      deallocate(SWdn200clr, SWdn200)
+      deallocate(SWup200clr, SWup200)
+      deallocate(LWdn200clr, LWdn200)
+      deallocate(LWup200clr, LWup200)
+      deallocate(LWdnTOA, LWdnTOAclr)
+! pressure level
+      deallocate(tsumSTD)
+      deallocate(usumSTD, vsumSTD)
+      deallocate(wsumSTD, phisumSTD)
+      deallocate(tnondef)
+      deallocate(qsumSTD, rhsumSTD)
+      deallocate(uvsumSTD)
+      deallocate(vqsumSTD)
+      deallocate(vTsumSTD)
+      deallocate(wqsumSTD)
+      deallocate(vphisumSTD)
+      deallocate(wTsumSTD)
+      deallocate(u2sumSTD)
+      deallocate(v2sumSTD)
+      deallocate(T2sumSTD)
+      deallocate(seed_old)
+      deallocate(zuthe, zvthe)
+      deallocate(alb_neig)
+      deallocate(ema_workcbmf, ema_cbmf)
+      deallocate(ema_pcb, ema_pct)
+      deallocate(Ma, qcondc)
+      deallocate(wd, sigd)
+      deallocate(cin, ALE, ALP)
+      deallocate(ftd, fqd)
+      deallocate(Ale_bl, Alp_bl)
+      deallocate(lalim_conv, wght_th)
+      deallocate(wake_deltat, wake_deltaq)
+      deallocate(wake_Cstar, wake_s, wake_fip)
+      deallocate(dt_wake, dq_wake)
+      deallocate(pfrac_impa, pfrac_nucl)
+      deallocate(pfrac_1nucl)
+      deallocate(total_rain, nday_rain)
+      deallocate(paire_ter)
+      deallocate(albsol1, albsol2)
+      deallocate(wo)
+      deallocate(clwcon0,rnebcon0)
+      deallocate(heat, heat0) 
+      deallocate(cool, cool0)
+      deallocate(topsw, toplw)
+      deallocate(sollwdown, sollwdownclr)
+      deallocate(toplwdown, toplwdownclr)
+      deallocate(topsw0,toplw0,solsw0,sollw0)
+      deallocate(albpla)
+      deallocate(cape)
+      deallocate(pbase,bbase)
+      deallocate(zqasc)
+      deallocate(ibas_con, itop_con)
+      deallocate(rain_con, snow_con)
+!
+      deallocate(sulfate_pi)
+      deallocate(rlonPOS)
+      deallocate(newsst)
+      deallocate(u10m, v10m)
+      deallocate(topswad, solswad)
+      deallocate(topswai, solswai)
+
+      deallocate(tau_ae, piz_ae)
+      deallocate(cg_ae)
+
+      IF (config_inca /= 'none') THEN
+         deallocate(topswad_inca, solswad_inca)
+         deallocate(topswad0_inca, solswad0_inca)
+         deallocate(topswai_inca, solswai_inca)
+         deallocate(topsw_inca, solsw_inca)
+         deallocate(topsw0_inca, solsw0_inca)
+      END IF
+      deallocate(tau_inca)
+      deallocate(piz_inca)
+      deallocate(cg_inca)
+      deallocate(ccm)
+       
+END SUBROUTINE phys_state_var_end
+
+      END MODULE phys_state_var_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/physiq.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/physiq.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/physiq.F	(revision 984)
@@ -0,0 +1,3436 @@
+!
+! $Header$
+!
+c
+c#define IO_DEBUG
+
+      SUBROUTINE physiq (nlon,nlev,nqmax,
+     .            debut,lafin,rjourvrai,gmtime,pdtphys,
+     .            paprs,pplay,pphi,pphis,presnivs,clesphy0,
+     .            u,v,t,qx,
+     .            flxmass_w,
+     .            d_u, d_v, d_t, d_qx, d_ps
+     .            , dudyn
+     .            , PVteta)
+
+      USE ioipsl
+      USE comgeomphy
+      USE write_field_phy
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE misc_mod, mydebug=>debug
+      USE vampir
+      USE pbl_surface_mod, ONLY : pbl_surface
+      USE surface_data,     ONLY : ocean, ok_veget
+      USE phys_local_var_mod ! Variables internes non sauvegardees de la physique
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+
+
+      USE ocean_slab_mod, ONLY   : ocean_slab_get_vars
+      USE ocean_cpl_mod, ONLY    : ocean_cpl_get_vars
+      USE ocean_forced_mod, ONLY : ocean_forced_get_vars
+      USE fonte_neige_mod, ONLY  : fonte_neige_get_vars
+      USE phys_output_mod
+
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c   CLEFS CPP POUR LES IO
+c   =====================
+c#define histhf
+#define histday
+#define histmth
+c#define histmthNMC
+c#define histins
+c#define histISCCP
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c nlon----input-I-nombre de points horizontaux
+c nlev----input-I-nombre de couches verticales
+c nqmax---input-I-nombre de traceurs (y compris vapeur d'eau) = 1
+c debut---input-L-variable logique indiquant le premier passage
+c lafin---input-L-variable logique indiquant le dernier passage
+c rjour---input-R-numero du jour de l'experience
+c gmtime--input-R-temps universel dans la journee (0 a 86400 s)
+c pdtphys-input-R-pas d'integration pour la physique (seconde)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
+c pphis---input-R-geopotentiel du sol
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+c u-------input-R-vitesse dans la direction X (de O a E) en m/s
+c v-------input-R-vitesse Y (de S a N) en m/s
+c t-------input-R-temperature (K)
+c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
+c d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
+c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
+c flxmass_w -input-R- flux de masse verticale
+c d_u-----output-R-tendance physique de "u" (m/s/s)
+c d_v-----output-R-tendance physique de "v" (m/s/s)
+c d_t-----output-R-tendance physique de "t" (K/s)
+c d_qx----output-R-tendance physique de "qx" (kg/kg/s)
+c d_ps----output-R-tendance physique de la pression au sol
+cIM
+c PVteta--output-R-vorticite potentielle a des thetas constantes
+c======================================================================
+#include "dimensions.h"
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
+      integer iip1
+      parameter (iip1=iim+1)
+
+#include "regdim.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "logic.h"
+#include "temps.h"
+cym#include "comgeomphy.h"
+#include "advtrac.h"
+#include "iniprint.h"
+#include "thermcell.h"
+c======================================================================
+      LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
+      PARAMETER (ok_cvl=.TRUE.)
+      LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
+      PARAMETER (ok_gust=.FALSE.)
+      integer iflag_radia     ! active ou non le rayonnement (MPL)
+      save iflag_radia
+c======================================================================
+      LOGICAL check ! Verifier la conservation du modele en eau
+      PARAMETER (check=.FALSE.)
+      LOGICAL ok_stratus ! Ajouter artificiellement les stratus
+      PARAMETER (ok_stratus=.FALSE.)
+c======================================================================
+      LOGICAL, SAVE :: rnpb=.TRUE.
+cIM "slab" ocean
+      REAL tslab(klon)    !Temperature du slab-ocean
+      REAL seaice(klon)   !glace de mer (kg/m2) 
+      REAL fluxo(klon)    !flux turbulents ocean-glace de mer 
+      REAL fluxg(klon)    !flux turbulents ocean-atmosphere
+      REAL amn, amx
+      INTEGER igout
+c======================================================================
+c Clef controlant l'activation du cycle diurne:
+ccc      LOGICAL cycle_diurne
+ccc      PARAMETER (cycle_diurne=.FALSE.)
+c======================================================================
+c Modele thermique du sol, a activer pour le cycle diurne:
+ccc      LOGICAL soil_model
+ccc      PARAMETER (soil_model=.FALSE.)
+c======================================================================
+c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
+c le calcul du rayonnement est celle apres la precipitation des nuages.
+c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
+c la condensation et la precipitation. Cette cle augmente les impacts
+c radiatifs des nuages.
+ccc      LOGICAL new_oliq
+ccc      PARAMETER (new_oliq=.FALSE.)
+c======================================================================
+c Clefs controlant deux parametrisations de l'orographie:
+cc      LOGICAL ok_orodr
+ccc      PARAMETER (ok_orodr=.FALSE.)
+ccc      LOGICAL ok_orolf
+ccc      PARAMETER (ok_orolf=.FALSE.)
+c======================================================================
+      LOGICAL ok_journe ! sortir le fichier journalier
+      save ok_journe
+c$OMP THREADPRIVATE(ok_journe)
+c
+      LOGICAL ok_mensuel ! sortir le fichier mensuel
+      save ok_mensuel
+c$OMP THREADPRIVATE(ok_mensuel)
+c
+      LOGICAL ok_instan ! sortir le fichier instantane
+      save ok_instan
+c$OMP THREADPRIVATE(ok_instan)
+c
+      LOGICAL ok_region ! sortir le fichier regional
+      PARAMETER (ok_region=.FALSE.)
+c======================================================================
+      real weak_inversion(klon),dthmin(klon)
+      real seuil_inversion
+      save seuil_inversion
+c$OMP THREADPRIVATE(seuil_inversion)
+      integer iflag_ratqs
+      save iflag_ratqs
+c$OMP THREADPRIVATE(iflag_ratqs)
+
+      integer lmax_th(klon)
+      integer limbas(klon)
+      real ratqscth(klon,klev)
+      real ratqsdiff(klon,klev)
+      real zqsatth(klon,klev)
+
+c======================================================================
+c
+      INTEGER ivap          ! indice de traceurs pour vapeur d'eau
+      PARAMETER (ivap=1)
+      INTEGER iliq          ! indice de traceurs pour eau liquide
+      PARAMETER (iliq=2)
+
+c
+c
+c Variables argument:
+c
+      INTEGER nlon
+      INTEGER nlev
+      INTEGER nqmax
+      REAL rjourvrai
+      REAL gmtime
+      REAL pdtphys
+      LOGICAL debut, lafin
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      REAL pphis(klon)
+      REAL presnivs(klev)
+      REAL znivsig(klev)
+      real pir
+
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL t(klon,klev),theta(klon,klev)
+      REAL qx(klon,klev,nqmax)
+      REAL flxmass_w(klon,klev)
+      REAL omega(klon,klev) ! vitesse verticale en Pa/s
+      REAL d_u(klon,klev)
+      REAL d_v(klon,klev)
+      REAL d_t(klon,klev)
+      REAL d_qx(klon,klev,nqmax)
+      REAL d_ps(klon)
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+c
+cIM Amip2 PV a theta constante 
+c
+      INTEGER nbteta
+      PARAMETER(nbteta=3)
+      CHARACTER*3 ctetaSTD(nbteta)
+      DATA ctetaSTD/'350','380','405'/
+      SAVE ctetaSTD
+c$OMP THREADPRIVATE(ctetaSTD)
+      REAL rtetaSTD(nbteta)
+      DATA rtetaSTD/350., 380., 405./
+      SAVE rtetaSTD
+c$OMP THREADPRIVATE(rtetaSTD)     
+c
+      REAL PVteta(klon,nbteta)
+      REAL zx_tmp_3dte(iim,jjmp1,nbteta)
+c
+cMI Amip2 PV a theta constante
+
+cym      INTEGER klevp1, klevm1
+cym      PARAMETER(klevp1=klev+1,klevm1=klev-1)
+cym#include "raddim.h"
+c
+c
+cIM Amip2
+c variables a une pression donnee
+c
+      real rlevSTD(nlevSTD)
+      DATA rlevSTD/100000., 92500., 85000., 70000.,
+     .60000., 50000., 40000., 30000., 25000., 20000.,
+     .15000., 10000., 7000., 5000., 3000., 2000., 1000./
+      SAVE rlevstd
+      CHARACTER*4 clevSTD(nlevSTD)
+      DATA clevSTD/'1000','925 ','850 ','700 ','600 ',
+     .'500 ','400 ','300 ','250 ','200 ','150 ','100 ',
+     .'70  ','50  ','30  ','20  ','10  '/
+      SAVE clevSTD
+c
+      CHARACTER*4 bb2
+      CHARACTER*2 bb3
+c
+      real tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD)
+      real rhlevSTD(klon,nlevSTD), philevSTD(klon,nlevSTD)
+      real ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD)
+      real wlevSTD(klon,nlevSTD) 
+c
+c nout : niveau de output des variables a une pression donnee
+      logical oknondef(klon,nlevSTD,nout)
+c
+c les produits uvSTD, vqSTD, .., T2STD sont calcules
+c a partir des valeurs instantannees toutes les 6 h
+c qui sont moyennees sur le mois
+c
+      real uvSTD(klon,nlevSTD)
+      real vqSTD(klon,nlevSTD)
+      real vTSTD(klon,nlevSTD)
+      real wqSTD(klon,nlevSTD)
+c
+      real vphiSTD(klon,nlevSTD)
+      real wTSTD(klon,nlevSTD)
+      real u2STD(klon,nlevSTD)
+      real v2STD(klon,nlevSTD)
+      real T2STD(klon,nlevSTD)
+c
+#include "radepsi.h"
+#include "radopt.h"
+c
+c
+c prw: precipitable water
+      real prw(klon)
+
+      REAL convliq(klon,klev)  ! eau liquide nuageuse convective
+      REAL convfra(klon,klev)  ! fraction nuageuse convective
+
+      REAL cldl_c(klon),cldm_c(klon),cldh_c(klon) !nuages bas, moyen et haut
+      REAL cldt_c(klon),cldq_c(klon) !nuage total, eau liquide integree
+      REAL cldl_s(klon),cldm_s(klon),cldh_s(klon) !nuages bas, moyen et haut
+      REAL cldt_s(klon),cldq_s(klon) !nuage total, eau liquide integree
+
+      INTEGER linv, kp1
+c flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2)
+c flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg)
+      REAL flwp(klon), fiwp(klon)
+      REAL flwc(klon,klev), fiwc(klon,klev)
+      REAL flwp_c(klon), fiwp_c(klon)
+      REAL flwc_c(klon,klev), fiwc_c(klon,klev)
+      REAL flwp_s(klon), fiwp_s(klon)
+      REAL flwc_s(klon,klev), fiwc_s(klon,klev)
+
+cIM ISCCP simulator v3.4
+c dans clesphys.h top_height, overlap
+cv3.4
+      INTEGER debug, debugcol
+cym      INTEGER npoints
+cym      PARAMETER(npoints=klon) 
+c
+      INTEGER sunlit(klon) !sunlit=1 if day; sunlit=0 if night
+      INTEGER nregISCtot
+      PARAMETER(nregISCtot=1) 
+c
+c imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire
+c y compris pour 1 point
+c imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude)
+c jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude)
+      INTEGER imin_debut, nbpti
+      INTEGER jmin_debut, nbptj 
+cIM parametres ISCCP BEG
+      INTEGER nbapp_isccp
+!     INTEGER nbapp_isccp,isccppas
+!     PARAMETER(isccppas=6) !appel du simulateurs tous les 6pas de temps de la physique
+!                           !i.e. toutes les 3 heures 
+      INTEGER n
+      INTEGER ifreq_isccp(napisccp), freqin_pdt(napisccp)
+      DATA ifreq_isccp/3/
+      SAVE ifreq_isccp
+c$OMP THREADPRIVATE(ifreq_isccp)
+      CHARACTER*5 typinout(napisccp)
+      DATA typinout/'i3od'/
+      SAVE typinout
+c$OMP THREADPRIVATE(typinout)
+cIM verif boxptop BEG
+      CHARACTER*1 verticaxe(napisccp)
+      DATA verticaxe/'1'/ 
+      SAVE verticaxe
+c$OMP THREADPRIVATE(verticaxe)
+cIM verif boxptop END
+      INTEGER nvlev(napisccp)
+c     INTEGER nvlev
+      REAL t1, aa
+      REAL seed_re(klon,napisccp)
+cym !!!! A voir plus tard 
+cym      INTEGER iphy(iim,jjmp1)
+cIM parametres ISCCP END
+c
+c ncol = nb. de sous-colonnes pour chaque maille du GCM 
+c ncolmx = No. max. de sous-colonnes pour chaque maille du GCM 
+c      INTEGER ncol(napisccp), ncolmx, seed(klon,napisccp)
+      INTEGER,SAVE :: ncol(napisccp)
+      INTEGER ncolmx, seed(klon,napisccp)
+      REAL nbsunlit(nregISCtot,klon,napisccp)  !nbsunlit : moyenne de sunlit
+c     PARAMETER(ncolmx=1500)
+      PARAMETER(ncolmx=300)
+c
+cIM verif boxptop BEG
+      REAL vertlev(ncolmx,napisccp)
+cIM verif boxptop END
+c
+      REAL,SAVE :: tautab_omp(0:255),tautab(0:255)
+      INTEGER,SAVE :: invtau_omp(-20:45000),invtau(-20:45000)
+c$OMP THREADPRIVATE(tautab,invtau)
+      REAL emsfc_lw
+      PARAMETER(emsfc_lw=0.99)
+c     REAL    ran0                      ! type for random number fuction
+c
+      REAL cldtot(klon,klev)
+c variables de haut en bas pour le simulateur ISCCP
+      REAL dtau_s(klon,klev) !tau nuages startiformes
+      REAL dtau_c(klon,klev) !tau nuages convectifs
+      REAL dem_s(klon,klev)  !emissivite nuages startiformes 
+      REAL dem_c(klon,klev)  !emissivite nuages convectifs
+c
+c variables de haut en bas pour le simulateur ISCCP
+      REAL pfull(klon,klev)
+      REAL phalf(klon,klev+1)
+      REAL qv(klon,klev)
+      REAL cc(klon,klev)
+      REAL conv(klon,klev)
+      REAL dtau_sH2B(klon,klev)
+      REAL dtau_cH2B(klon,klev)
+      REAL at(klon,klev)
+      REAL dem_sH2B(klon,klev)
+      REAL dem_cH2B(klon,klev)
+c
+      INTEGER kmax, lmax, lmax3
+      PARAMETER(kmax=8, lmax=8, lmax3=3)
+      INTEGER kmaxm1, lmaxm1
+      PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1)
+      INTEGER iimx7, jjmx7, jjmp1x7
+      PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1, 
+     .jjmp1x7=jjmp1*lmaxm1)
+c
+c output from ISCCP simulator
+      REAL fq_isccp(klon,kmaxm1,lmaxm1,napisccp)
+      REAL fq_is_true(klon,kmaxm1,lmaxm1,napisccp)
+      REAL totalcldarea(klon,napisccp) 
+      REAL meanptop(klon,napisccp)
+      REAL meantaucld(klon,napisccp)
+      REAL boxtau(klon,ncolmx,napisccp)
+      REAL boxptop(klon,ncolmx,napisccp) 
+      REAL zx_tmp_fi3d_bx(klon,ncolmx)
+      REAL zx_tmp_3d_bx(iim,jjmp1,ncolmx)
+c
+      REAL cld_fi3d(klon,lmax3)
+      REAL cld_3d(iim,jjmp1,lmax3)
+c
+      INTEGER iw, iwmax
+      REAL wmin, pas_w
+c     PARAMETER(wmin=-100.,pas_w=10.,iwmax=30)
+cIM 051005     PARAMETER(wmin=-200.,pas_w=10.,iwmax=40)
+      PARAMETER(wmin=-100.,pas_w=10.,iwmax=20)
+      REAL o500(klon)
+c
+
+c sorties ISCCP
+
+      integer nid_isccp
+      save nid_isccp        
+c$OMP THREADPRIVATE(nid_isccp)
+
+      REAL zx_tau(kmaxm1), zx_pc(lmaxm1), zx_o500(iwmax)
+      DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./
+      SAVE zx_tau
+      DATA zx_pc/180., 310., 440., 560., 680., 800., 1000./
+      SAVE zx_pc
+c$OMP THREADPRIVATE(zx_tau,zx_pc)
+c cldtopres pression au sommet des nuages
+      REAL cldtopres(lmaxm1), cldtopres3(lmax3)
+      DATA cldtopres/180., 310., 440., 560., 680., 800., 1000./
+      DATA cldtopres3/440., 680., 1000./
+      SAVE cldtopres,cldtopres3
+c$OMP THREADPRIVATE(cldtopres,cldtopres3)
+cIM 051005 BEG
+      INTEGER komega, nhoriRD 
+
+c taulev: numero du niveau de tau dans les sorties ISCCP
+      CHARACTER *4 taulev(kmaxm1)
+c     DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/
+      DATA taulev/'tau0','tau1','tau2','tau3','tau4','tau5','tau6'/
+      CHARACTER *3 pclev(lmaxm1)
+      DATA pclev/'pc1','pc2','pc3','pc4','pc5','pc6','pc7'/
+      SAVE taulev,pclev
+c$OMP THREADPRIVATE(taulev,pclev)
+c
+c cnameisccp
+      CHARACTER *27 cnameisccp(lmaxm1,kmaxm1)
+cIM bad 151205     DATA cnameisccp/'pc< 50hPa, tau< 0.3', 
+      DATA cnameisccp/'pc= 50-180hPa, tau< 0.3',
+     .                'pc= 180-310hPa, tau< 0.3',
+     .                'pc= 310-440hPa, tau< 0.3',
+     .                'pc= 440-560hPa, tau< 0.3',
+     .                'pc= 560-680hPa, tau< 0.3',
+     .                'pc= 680-800hPa, tau< 0.3',
+     .                'pc= 800-1000hPa, tau< 0.3',
+     .                'pc= 50-180hPa, tau= 0.3-1.3',
+     .                'pc= 180-310hPa, tau= 0.3-1.3',
+     .                'pc= 310-440hPa, tau= 0.3-1.3',
+     .                'pc= 440-560hPa, tau= 0.3-1.3',
+     .                'pc= 560-680hPa, tau= 0.3-1.3',
+     .                'pc= 680-800hPa, tau= 0.3-1.3',
+     .                'pc= 800-1000hPa, tau= 0.3-1.3',
+     .                'pc= 50-180hPa, tau= 1.3-3.6',
+     .                'pc= 180-310hPa, tau= 1.3-3.6',
+     .                'pc= 310-440hPa, tau= 1.3-3.6',
+     .                'pc= 440-560hPa, tau= 1.3-3.6',
+     .                'pc= 560-680hPa, tau= 1.3-3.6',
+     .                'pc= 680-800hPa, tau= 1.3-3.6',
+     .                'pc= 800-1000hPa, tau= 1.3-3.6',
+     .                'pc= 50-180hPa, tau= 3.6-9.4',
+     .                'pc= 180-310hPa, tau= 3.6-9.4',
+     .                'pc= 310-440hPa, tau= 3.6-9.4',
+     .                'pc= 440-560hPa, tau= 3.6-9.4',
+     .                'pc= 560-680hPa, tau= 3.6-9.4',
+     .                'pc= 680-800hPa, tau= 3.6-9.4',
+     .                'pc= 800-1000hPa, tau= 3.6-9.4',
+     .                'pc= 50-180hPa, tau= 9.4-23',
+     .                'pc= 180-310hPa, tau= 9.4-23',
+     .                'pc= 310-440hPa, tau= 9.4-23',
+     .                'pc= 440-560hPa, tau= 9.4-23',
+     .                'pc= 560-680hPa, tau= 9.4-23',
+     .                'pc= 680-800hPa, tau= 9.4-23',
+     .                'pc= 800-1000hPa, tau= 9.4-23',
+     .                'pc= 50-180hPa, tau= 23-60',
+     .                'pc= 180-310hPa, tau= 23-60',
+     .                'pc= 310-440hPa, tau= 23-60',
+     .                'pc= 440-560hPa, tau= 23-60',
+     .                'pc= 560-680hPa, tau= 23-60',
+     .                'pc= 680-800hPa, tau= 23-60',
+     .                'pc= 800-1000hPa, tau= 23-60',
+     .                'pc= 50-180hPa, tau> 60.',
+     .                'pc= 180-310hPa, tau> 60.',
+     .                'pc= 310-440hPa, tau> 60.',
+     .                'pc= 440-560hPa, tau> 60.',
+     .                'pc= 560-680hPa, tau> 60.',
+     .                'pc= 680-800hPa, tau> 60.',
+     .                'pc= 800-1000hPa, tau> 60.'/
+       SAVE cnameisccp
+c$OMP THREADPRIVATE(cnameisccp)
+c
+c     REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7)
+c     INTEGER nhorix7
+cIM: region='3d' <==> sorties en global
+      CHARACTER*3 region
+      PARAMETER(region='3d')
+c
+cIM ISCCP simulator v3.4
+c
+      logical ok_hf
+c
+      integer nid_hf, nid_hf3d
+      save ok_hf, nid_hf, nid_hf3d
+c$OMP THREADPRIVATE(ok_hf, nid_hf, nid_hf3d)
+c  QUESTION : noms de variables ?
+
+c#ifdef histhf
+c      data ok_hf/.true./
+c#else
+c      data ok_hf/.false./
+c#endif
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles      )
+c
+c Variables quasi-arguments
+c
+      REAL xjour
+      SAVE xjour
+c$OMP THREADPRIVATE(xjour)
+c
+c
+c Variables propres a la physique
+c
+c      INTEGER radpas
+c      SAVE radpas                 ! frequence d'appel rayonnement
+ccccccccc$OMP THREADPRIVATE(radpas)
+c
+cc      INTEGER iflag_con
+cc      SAVE iflag_con              ! indicateur de la convection
+c
+      INTEGER itap
+      SAVE itap                   ! compteur pour la physique
+c$OMP THREADPRIVATE(itap)
+c
+      real slp(klon) ! sea level pressure
+c
+      REAL fevap(klon,nbsrf)
+      REAL fluxlat(klon,nbsrf)
+c
+      REAL qsol(klon)
+      REAL,save ::  solarlong0
+c
+c  Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
+c
+cIM 141004     REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
+      REAL zulow(klon),zvlow(klon)
+c
+      INTEGER igwd,idx(klon),itest(klon)
+c
+      REAL agesno(klon,nbsrf)
+c
+c      REAL,allocatable,save :: run_off_lic_0(:)
+cc$OMP THREADPRIVATE(run_off_lic_0)
+cym      SAVE run_off_lic_0
+cKE43
+c Variables liees a la convection de K. Emanuel (sb):
+c
+      REAL bas, top             ! cloud base and top levels
+      SAVE bas
+      SAVE top
+c$OMP THREADPRIVATE(bas, top)
+
+      REAL wdn(klon), tdn(klon), qdn(klon)
+c
+c=================================================================================================
+cCR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides
+c Variables liées à la poche froide (jyg)
+
+      REAL mip(klon,klev)  ! mass flux shed by the adiab ascent at each level
+      REAL Vprecip(klon,klev)   ! precipitation vertical profile
+c
+      REAL wape_prescr, fip_prescr
+      INTEGER it_wape_prescr
+      SAVE wape_prescr, fip_prescr, it_wape_prescr
+c
+c variables supplementaires de concvl
+      REAL Tconv(klon,klev)
+      REAL ment(klon,klev,klev),sij(klon,klev,klev)
+      REAL dd_t(klon,klev),dd_q(klon,klev)
+
+      real, save :: alp_bl_prescr=0.
+      real, save :: ale_bl_prescr=0.
+
+      real, save :: ale_max=100.
+      real, save :: alp_max=2.
+
+c$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr)
+
+      real ale_wake(klon)
+      real alp_wake(klon)
+cRC
+c Variables liées à la poche froide (jyg et rr)
+c Version diagnostique pour l'instant : pas de rétroaction sur la convection
+
+      REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection
+
+      REAL wake_dth(klon,klev)        ! wake : temp pot difference
+
+      REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s)
+      REAL wake_omgbdth(klon,klev)    ! Wake : flux of Delta_Theta transported by LS omega
+      REAL wake_dp_omgb(klon,klev)    ! Wake : vertical gradient of large scale omega
+      REAL wake_dtKE(klon,klev)       ! Wake : differential heating (wake - unpertubed) CONV
+      REAL wake_dqKE(klon,klev)       ! Wake : differential moistening (wake - unpertubed) CONV
+      REAL wake_dtPBL(klon,klev)      ! Wake : differential heating (wake - unpertubed) PBL
+      REAL wake_dqPBL(klon,klev)      ! Wake : differential moistening (wake - unpertubed) PBL
+      REAL wake_omg(klon,klev)        ! Wake : velocity difference (wake - unpertubed)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg
+      REAL wake_spread(klon,klev)     ! spreading term in wake_delt
+c
+cpourquoi y'a pas de save??
+      REAL wake_h(klon)               ! Wake : hauteur de la poche froide
+c
+      INTEGER wake_k(klon)            ! Wake sommet
+c
+      REAL t_undi(klon,klev)               ! temperature moyenne dans la zone non perturbee
+      REAL q_undi(klon,klev)               ! humidite moyenne dans la zone non perturbee
+c
+      REAL wake_pe(klon)              ! Wake potential energy - WAPE 
+
+      REAL wake_gfl(klon)             ! Gust Front Length
+      REAL wake_dens(klon)
+c
+c
+      REAL dt_dwn(klon,klev)
+      REAL dq_dwn(klon,klev)
+      REAL wdt_PBL(klon,klev)
+      REAL udt_PBL(klon,klev)
+      REAL wdq_PBL(klon,klev)
+      REAL udq_PBL(klon,klev)
+      REAL M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev)
+      REAL dq_a(klon,klev)
+c
+cRR:fin declarations poches froides
+c=======================================================================================================
+
+c Variables locales pour la couche limite (al1):
+c
+cAl1      REAL pblh(klon)           ! Hauteur de couche limite
+cAl1      SAVE pblh
+c34EK
+c
+c Variables locales:
+c
+      REAL cdragh(klon) ! drag coefficient pour T and Q
+      REAL cdragm(klon) ! drag coefficient pour vent
+cAA
+cAA  Pour phytrac 
+cAA
+      REAL ycoefh(klon,klev)    ! coef d'echange pour phytrac
+      REAL yu1(klon)            ! vents dans la premiere couche U
+      REAL yv1(klon)            ! vents dans la premiere couche V
+
+      REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon)
+
+c@$$      LOGICAL offline           ! Controle du stockage ds "physique"
+c@$$      PARAMETER (offline=.false.)
+c@$$      INTEGER physid
+      REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
+      REAL frac_nucl(klon,klev) ! idem (nucleation)
+      INTEGER       :: iii
+      REAL          :: calday
+
+cIM cf FH pour Tiedtke 080604
+      REAL rain_tiedtke(klon),snow_tiedtke(klon)
+c
+cIM 050204 END
+      REAL evap(klon), devap(klon) ! evaporation et sa derivee
+      REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
+
+      REAL bils(klon) ! bilan de chaleur au sol
+      REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque
+C                             ! type de sous-surface et pondere par la fraction
+      REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque
+C                             ! type de sous-surface et pondere par la fraction
+      REAL fder(klon)         
+      REAL ve(klon) ! integr. verticale du transport meri. de l'energie
+      REAL vq(klon) ! integr. verticale du transport meri. de l'eau
+      REAL ue(klon) ! integr. verticale du transport zonal de l'energie
+      REAL uq(klon) ! integr. verticale du transport zonal de l'eau
+c
+      REAL frugs(klon,nbsrf)
+      REAL zxrugs(klon) ! longueur de rugosite
+c
+c Conditions aux limites
+c
+      INTEGER julien
+c
+      INTEGER lmt_pas
+      SAVE lmt_pas                ! frequence de mise a jour
+c$OMP THREADPRIVATE(lmt_pas) 
+cIM
+      REAL pctsrf_new(klon,nbsrf) !pourcentage surfaces issus d'ORCHIDEE
+
+cym      SAVE pctsrf                 ! sous-fraction du sol
+
+cIM sorties
+      REAL un_jour
+      PARAMETER(un_jour=86400.)
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+      EXTERNAL angle     ! calculer angle zenithal du soleil
+      EXTERNAL alboc     ! calculer l'albedo sur ocean
+      EXTERNAL ajsec     ! ajustement sec
+      EXTERNAL conlmd    ! convection (schema LMD)
+cKE43
+      EXTERNAL conema3  ! convect4.3
+      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
+cAA 
+      EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
+c                          ! stockage des coefficients necessaires au
+c                          ! lessivage OFF-LINE et ON-LINE
+      EXTERNAL hgardfou  ! verifier les temperatures
+      EXTERNAL nuage     ! calculer les proprietes radiatives
+      EXTERNAL o3cm      ! initialiser l'ozone
+      EXTERNAL orbite    ! calculer l'orbite terrestre
+      EXTERNAL ozonecm   ! prescrire l'ozone
+      EXTERNAL phyetat0  ! lire l'etat initial de la physique
+      EXTERNAL phyredem  ! ecrire l'etat de redemarrage de la physique
+      EXTERNAL radlwsw   ! rayonnements solaire et infrarouge
+      EXTERNAL suphel    ! initialiser certaines constantes
+      EXTERNAL transp    ! transport total de l'eau et de l'energie
+      EXTERNAL ecribina  ! ecrire le fichier binaire global
+      EXTERNAL ecribins  ! ecrire le fichier binaire global
+      EXTERNAL ecrirega  ! ecrire le fichier binaire regional
+      EXTERNAL ecriregs  ! ecrire le fichier binaire regional
+cIM
+      EXTERNAL haut2bas  !variables de haut en bas
+      INTEGER lnblnk1
+      EXTERNAL lnblnk1   !enleve les blancs a la fin d'une variable de type
+                         !caracter
+      EXTERNAL ini_undefSTD  !initialise a 0 une variable a 1 niveau de pression
+      EXTERNAL undefSTD      !somme les valeurs definies d'1 var a 1 niveau de pression
+c     EXTERNAL moy_undefSTD  !moyenne d'1 var a 1 niveau de pression
+c     EXTERNAL moyglo_aire   !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire)
+c                            !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
+c
+c Variables locales
+c
+      REAL rhcl(klon,klev)    ! humiditi relative ciel clair
+      REAL dialiq(klon,klev)  ! eau liquide nuageuse
+      REAL diafra(klon,klev)  ! fraction nuageuse
+      REAL cldliq(klon,klev)  ! eau liquide nuageuse
+      REAL cldfra(klon,klev)  ! fraction nuageuse
+      REAL cldtau(klon,klev)  ! epaisseur optique
+      REAL cldemi(klon,klev)  ! emissivite infrarouge
+c
+CXXX PB 
+      REAL fluxq(klon,klev, nbsrf)   ! flux turbulent d'humidite
+      REAL fluxt(klon,klev, nbsrf)   ! flux turbulent de chaleur
+      REAL fluxu(klon,klev, nbsrf)   ! flux turbulent de vitesse u
+      REAL fluxv(klon,klev, nbsrf)   ! flux turbulent de vitesse v
+c
+      REAL zxfluxt(klon, klev)
+      REAL zxfluxq(klon, klev)
+      REAL zxfluxu(klon, klev)
+      REAL zxfluxv(klon, klev)
+CXXX
+c
+      REAL fsollw(klon, nbsrf)   ! bilan flux IR pour chaque sous surface
+      REAL fsolsw(klon, nbsrf)   ! flux solaire absorb. pour chaque sous surface
+c Le rayonnement n'est pas calcule tous les pas, il faut donc
+c                      sauvegarder les sorties du rayonnement
+cym      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
+cym      SAVE  sollwdownclr, toplwdown, toplwdownclr
+cym      SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
+c
+      INTEGER itaprad
+      SAVE itaprad
+c$OMP THREADPRIVATE(itaprad)
+c
+      REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
+      REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
+c
+      REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut
+      REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
+c
+      REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon)
+      REAL zxsnow_dummy(klon)
+c
+      REAL dist, rmu0(klon), fract(klon)
+      REAL zdtime, zlongi
+c
+      CHARACTER*2 str2
+      CHARACTER*2 iqn
+c
+      REAL qcheck
+      REAL z_avant(klon), z_apres(klon), z_factor(klon)
+      LOGICAL zx_ajustq
+c
+      REAL za, zb
+      REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
+      real zqsat(klon,klev)
+      INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq, iff
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zphi(klon,klev)
+cym A voir plus tard !!
+cym      REAL zx_relief(iim,jjmp1)
+cym      REAL zx_aire(iim,jjmp1)
+c
+c Grandeurs de sorties
+      REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)
+      REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)
+      REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon)
+      REAL s_trmb3(klon)
+cKE43
+c Variables locales pour la convection de K. Emanuel (sb):
+c
+      REAL upwd(klon,klev)      ! saturated updraft mass flux
+      REAL dnwd(klon,klev)      ! saturated downdraft mass flux
+      REAL dnwd0(klon,klev)     ! unsaturated downdraft mass flux
+      REAL tvp(klon,klev)       ! virtual temp of lifted parcel
+      CHARACTER*40 capemaxcels  !max(CAPE)
+
+      REAL rflag(klon)          ! flag fonctionnement de convect
+      INTEGER iflagctrl(klon)          ! flag fonctionnement de convect
+c -- convect43:
+      INTEGER ntra              ! nb traceurs pour convect4.3
+      REAL pori_con(klon)    ! pressure at the origin level of lifted parcel
+      REAL plcl_con(klon),dtma_con(klon),dtlcl_con(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+c?     .     condm_con(klon,klev),conda_con(klon,klev),
+c?     .     mr_con(klon,klev),ep_con(klon,klev)
+c?     .    ,sadiab(klon,klev),wadiab(klon,klev)
+c --
+c34EK
+c
+c Variables du changement
+c
+c con: convection
+c lsc: condensation a grande echelle (Large-Scale-Condensation)
+c ajs: ajustement sec
+c eva: evaporation de l'eau liquide nuageuse
+c vdf: couche limite (Vertical DiFfusion)
+      REAL rneb(klon,klev)
+
+! tendance nulles
+      REAL du0(klon,klev),dv0(klon,klev),dq0(klon,klev),dql0(klon,klev)
+
+c
+*********************************************************
+*     declarations
+      
+*********************************************************
+cIM 081204 END
+c
+      REAL pmfu(klon,klev), pmfd(klon,klev)
+      REAL pen_u(klon,klev), pen_d(klon,klev)
+      REAL pde_u(klon,klev), pde_d(klon,klev)
+      INTEGER kcbot(klon), kctop(klon), kdtop(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      REAL prfl(klon,klev+1), psfl(klon,klev+1)
+c
+      REAL rain_lsc(klon)
+      REAL snow_lsc(klon)
+c
+      REAL ratqss(klon,klev),ratqsc(klon,klev)
+      real ratqsbas,ratqshaut
+      save ratqsbas,ratqshaut
+      real zpt_conv(klon,klev)
+
+c Parametres lies au nouveau schema de nuages (SB, PDF)
+      real fact_cldcon
+      real facttemps
+      logical ok_newmicro
+      save ok_newmicro
+c$OMP THREADPRIVATE(ok_newmicro)
+      save fact_cldcon,facttemps
+c$OMP THREADPRIVATE(fact_cldcon,facttemps)
+      real facteur
+
+      integer iflag_cldcon
+      save iflag_cldcon
+c$OMP THREADPRIVATE(iflag_cldcon)
+      logical ptconv(klon,klev)
+cIM cf. AM 081204 BEG
+      logical ptconvth(klon,klev)
+cIM cf. AM 081204 END
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c======================================================================
+c
+cIM cf. AM 081204 BEG
+c   declarations pour sortir sur une sous-region
+      integer imin_ins,imax_ins,jmin_ins,jmax_ins
+      save imin_ins,imax_ins,jmin_ins,jmax_ins
+c$OMP THREADPRIVATE(imin_ins,imax_ins,jmin_ins,jmax_ins)
+c      real lonmin_ins,lonmax_ins,latmin_ins
+c     s  ,latmax_ins
+c     data lonmin_ins,lonmax_ins,latmin_ins
+c    s  ,latmax_ins/
+c valeurs initiales     s   -5.,20.,41.,55./   
+c    s   100.,130.,-20.,20./
+c    s   -180.,180.,-90.,90./
+c======================================================================
+cIM cf. AM 081204 END
+
+c
+      integer itau_w   ! pas de temps ecriture = itap + itau_phy
+c
+c
+c Variables locales pour effectuer les appels en serie
+c
+      REAL zx_rh(klon,klev)
+cIM RH a 2m (la surface)
+      REAL rh2m(klon), qsat2m(klon)
+      REAL tpot(klon), tpote(klon)
+      REAL Lheat
+
+      INTEGER        length
+      PARAMETER    ( length = 100 )
+      REAL tabcntr0( length       )
+c
+      INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev)
+cIM
+      INTEGER ndex2d1(iwmax)
+c
+cIM AMIP2 BEG
+      REAL moyglo, mountor
+cIM 141004 BEG
+      REAL zustrdr(klon), zvstrdr(klon)
+      REAL zustrli(klon), zvstrli(klon)
+      REAL zustrph(klon), zvstrph(klon)
+      REAL aam, torsfc
+cIM 141004 END
+cIM 190504 BEG
+      INTEGER ij, imp1jmp1
+      PARAMETER(imp1jmp1=(iim+1)*jjmp1)
+cym A voir plus tard
+      REAL zx_tmp(imp1jmp1), airedyn(iim+1,jjmp1)
+      REAL padyn(iim+1,jjmp1,klev+1)
+      REAL dudyn(iim+1,jjmp1,klev)
+      REAL rlatdyn(iim+1,jjmp1)
+cIM 190504 END
+      LOGICAL ok_msk
+      REAL msk(klon)
+cIM 
+      REAL airetot, pi
+cym A voir plus tard
+cym      REAL zm_wo(jjmp1, klev)
+cIM AMIP2 END
+c
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+c#ifdef histmthNMC
+cym   A voir plus tard !!!!
+cym      REAL zx_tmp_NC(iim,jjmp1,nlevSTD)
+      REAL zx_tmp_fiNC(klon,nlevSTD) 
+c#endif
+      REAL*8 zx_tmp2_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev)
+      REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1)
+c
+      INTEGER nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri
+      INTEGER nid_ctesGCM
+      SAVE nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri
+      SAVE nid_ctesGCM
+c$OMP THREADPRIVATE(nid_day, nid_mth, nid_ins, nid_nmc)
+c$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM)
+c
+cIM 280405 BEG
+      INTEGER nid_bilKPins, nid_bilKPave
+      SAVE nid_bilKPins, nid_bilKPave
+c$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave)
+c
+      REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert.
+      REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert.
+      REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert.
+      REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert.
+c
+cIM 280405 END
+c
+      INTEGER nhori, nvert, nvert1, nvert3
+      REAL zsto, zsto1, zsto2
+      REAL zstophy, zstorad, zstohf, zstoday, zstomth, zout
+      REAL zcals(napisccp), zcalh(napisccp), zoutj(napisccp)
+      REAL zout_isccp(napisccp)
+      SAVE zcals, zcalh, zoutj, zout_isccp
+c$OMP THREADPRIVATE(zcals, zcalh, zoutj, zout_isccp)
+
+      real zjulian
+      save zjulian
+c$OMP THREADPRIVATE(zjulian)
+
+      character*20 modname
+      character*80 abort_message
+      logical ok_sync
+      real date0
+      integer idayref
+
+C essai writephys
+      integer fid_day, fid_mth, fid_ins
+      parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 
+      integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
+      parameter (prof2d_on = 1, prof3d_on = 2,
+     .           prof2d_av = 3, prof3d_av = 4)
+      character*30 nom_fichier
+      character*10 varname
+      character*40 vartitle
+      character*20 varunits
+C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot,
+c$OMP+              h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+c$OMP THREADPRIVATE(d_h_vcol_phy)
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/0/
+c$OMP THREADPRIVATE(ip_ebil)
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+c$OMP THREADPRIVATE(if_ebil)
+c+jld ec_conser
+      REAL ZRCPD
+c-jld ec_conser
+      REAL t2m(klon,nbsrf)  ! temperature a 2m
+      REAL q2m(klon,nbsrf)  ! humidite a 2m
+
+cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels
+      REAL zt2m(klon), zq2m(klon)             !temp., hum. 2m moyenne s/ 1 maille
+      REAL zu10m(klon), zv10m(klon)           !vents a 10m moyennes s/1 maille
+      CHARACTER*40 t2mincels, t2maxcels       !t2m min., t2m max
+      CHARACTER*40 tinst, tave, typeval
+cjq   Aerosol effects (Johannes Quaas, 27/11/2003)
+      REAL sulfate(klon, klev) ! SO4 aerosol concentration [ug/m3]
+
+      REAL cldtaupi(klon,klev)  ! Cloud optical thickness for pre-industrial (pi) aerosols
+
+      REAL re(klon, klev)       ! Cloud droplet effective radius
+      REAL fl(klon, klev)  ! denominator of re
+
+      REAL re_top(klon), fl_top(klon) ! CDR at top of liquid water clouds
+
+      ! Aerosol optical properties
+
+      ! Aerosol optical properties by INCA model 
+      CHARACTER*4              ::    rfname(9) 
+      REAL aerindex(klon)       ! POLDER aerosol index
+     
+      ! Parameters
+      LOGICAL ok_ade, ok_aie    ! Apply aerosol (in)direct effects or not
+      REAL bl95_b0, bl95_b1   ! Parameter in Boucher and Lohmann (1995)
+      SAVE ok_ade, ok_aie, bl95_b0, bl95_b1
+c$OMP THREADPRIVATE(ok_ade, ok_aie, bl95_b0, bl95_b1)
+      LOGICAL, SAVE :: aerosol_couple ! true  : calcul des aerosols dans INCA
+                                      ! false : lecture des aerosol dans un fichier
+c$OMP THREADPRIVATE(aerosol_couple)    
+
+c
+c Declaration des constantes et des fonctions thermodynamiques
+c
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+cIM 100106 BEG : pouvoir sortir les ctes de la physique
+#include "conema3.h"
+#include "fisrtilp.h"
+#include "nuage.h"
+#include "compbl.h"
+cIM 100106 END : pouvoir sortir les ctes de la physique
+c
+c======================================================================
+! Ecriture eventuelle d'un profil verticale en entree de la physique.
+! Utilise notamment en 1D mais peut etre active egalement en 3D
+! en imposant la valeur de igout.
+c======================================================================
+
+      if (prt_level.ge.1) then
+          igout=klon/2+1/klon
+         write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
+         write(lunout,*)
+     s 'nlon,nlev,nqmax,debut,lafin,rjourvrai,gmtime,pdtphys'
+         write(lunout,*)
+     s  nlon,nlev,nqmax,debut,lafin,rjourvrai,gmtime,pdtphys 
+
+         write(lunout,*) 'papers, play, phi, u, v, t, omega'
+         do k=1,nlev
+            write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k),
+     s   u(igout,k),v(igout,k),t(igout,k),omega(igout,k)
+         enddo
+         write(lunout,*) 'ovap (g/kg),  oliq (g/kg)'
+         do k=1,nlev
+            write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000.
+         enddo
+      endif
+
+c======================================================================
+
+cym => necessaire pour iflag_con != 2    
+      pmfd(:,:) = 0.
+      pen_u(:,:) = 0.
+      pen_d(:,:) = 0.
+      pde_d(:,:) = 0.
+      pde_u(:,:) = 0.
+      aam=0.
+      torsfc=0.
+
+      if (first) then 
+      
+cCR:nvelles variables convection/poches froides
+      
+      print*, '================================================='
+      print*, 'Allocation des variables locales et sauvegardees'
+      call phys_local_var_init
+      call phys_state_var_init
+      print*, '================================================='
+
+cIM beg
+          dnwd0=0.0
+          ftd=0.0
+          fqd=0.0
+          cin=0.
+cym Attention pbase pas initialise dans concvl !!!!
+          pbase=0
+          paire_ter(:)=0.    
+cIM 180608
+c         pmflxr=0.
+c         pmflxs=0.
+	first=.false.
+
+      endif  ! fisrt
+
+       modname = 'physiq'
+cIM
+      IF (ip_ebil_phy.ge.1) THEN
+        DO i=1,klon
+          zero_v(i)=0.
+        END DO 
+      END IF 
+      ok_sync=.TRUE.
+      IF (nqmax .LT. 2) THEN
+         abort_message = 'eaux vapeur et liquide sont indispensables'
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      IF (debut) THEN
+         CALL suphel ! initialiser constantes et parametres phys.
+      ENDIF
+
+      if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 '
+
+
+c======================================================================
+      xjour = rjourvrai
+c
+c Si c'est le debut, il faut initialiser plusieurs choses
+c          ********
+c
+       IF (debut) THEN
+C
+!rv
+cCRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation 
+cde la convection a partir des caracteristiques du thermique
+         wght_th(:,:)=1.
+         lalim_conv(:)=1 
+cRC
+         u10m(:,:)=0.
+         v10m(:,:)=0.
+         piz_ae(:,:,:)=0.
+         tau_ae(:,:,:)=0.
+         cg_ae(:,:,:)=0.
+         rain_con(:)=0.
+         snow_con(:)=0.
+         bl95_b0=0.
+         bl95_b1=0.
+         topswai(:)=0.
+         topswad(:)=0.
+         solswai(:)=0.
+         solswad(:)=0.
+
+         IF (config_inca /= 'none') THEN
+            tau_inca(:,:,:,:) = 0.
+            piz_inca(:,:,:,:) = 0.
+            cg_inca(:,:,:,:)  = 0.
+            ccm(:,:,:)        = 0.
+            topswai_inca(:)   = 0.
+            topswad_inca(:)   = 0.
+            topswad0_inca(:)  = 0.
+            topsw_inca(:,:)   = 0.
+            topsw0_inca(:,:)  = 0.
+            solswai_inca(:)   = 0.
+            solswad_inca(:)   = 0.
+            solswad0_inca(:)  = 0.
+            solsw_inca(:,:)   = 0.
+            solsw0_inca(:,:)  = 0.
+         END IF
+
+         rnebcon0(:,:) = 0.0
+         clwcon0(:,:) = 0.0
+         rnebcon(:,:) = 0.0
+         clwcon(:,:) = 0.0
+
+cIM      
+         IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0.
+c
+c appel a la lecture du run.def physique
+c
+         call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel,
+     .                  ok_instan, ok_hf,
+     .                  solarlong0,seuil_inversion,
+     .                  fact_cldcon, facttemps,ok_newmicro,iflag_radia,
+     .                  iflag_cldcon,iflag_ratqs,ratqsbas,ratqshaut,
+     .                  ok_ade, ok_aie, aerosol_couple, 
+     .                  bl95_b0, bl95_b1,
+     .                  iflag_thermals,nsplit_thermals,tau_thermals,
+cnv flags pour la convection et les poches froides
+     .                   iflag_coupl,iflag_clos,iflag_wake)
+
+      print*,'iflag_coupl,iflag_clos,iflag_wake',
+     .   iflag_coupl,iflag_clos,iflag_wake
+      print*,'CYCLE_DIURNE', cycle_diurne
+
+c
+c
+c Initialiser les compteurs:
+c
+         itap    = 0
+         itaprad = 0
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Un petit travail à faire ici.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         if (iflag_pbl>1) then
+             PRINT*, "Using method MELLOR&YAMADA" 
+         endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que
+! dyn3d
+! Attention : la version precedente n'etait pas tres propre.
+! Il se peut qu'il faille prendre une valeur differente de nbapp_rad
+! pour obtenir le meme resultat.
+         dtime=pdtphys
+         radpas = NINT( 86400./dtime/nbapp_rad)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         CALL phyetat0 ("startphy.nc",ocean, ok_veget,clesphy0,tabcntr0)
+cIM begin
+          print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1)
+     $,ratqs(1,1)
+cIM end
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+       DO i=1,klon
+         IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + 
+     $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
+     $       THEN 
+            WRITE(*,*)
+     $   'physiq apres lecture de restart: pb sous surface au point ',
+     $   i, pctsrf(i, 1 : nbsrf)
+         ENDIF 
+      ENDDO
+
+c
+C on remet le calendrier a zero
+c
+         IF (raz_date .eq. 1) THEN
+           itau_phy = 0
+         ENDIF
+
+cIM cf. AM 081204 BEG
+         PRINT*,'cycle_diurne3 =',cycle_diurne
+cIM cf. AM 081204 END
+c
+         CALL printflag( tabcntr0,radpas,ok_journe,
+     ,                    ok_instan, ok_region )
+c
+         IF (ABS(dtime-pdtphys).GT.0.001) THEN
+            WRITE(lunout,*) 'Pas physique n est pas correct',dtime,
+     .                        pdtphys
+            abort_message='Pas physique n est pas correct '
+!           call abort_gcm(modname,abort_message,1)
+            dtime=pdtphys
+         ENDIF
+         IF (nlon .NE. klon) THEN
+            WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, 
+     .                      klon
+            abort_message='nlon et klon ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlev .NE. klev) THEN
+            WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev,
+     .                       klev
+            abort_message='nlev et klev ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+c
+         IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN 
+           WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
+           WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
+           abort_message='Nbre d appels au rayonnement insuffisant'
+           call abort_gcm(modname,abort_message,1)
+         ENDIF
+         WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con
+         WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=",
+     .                   ok_cvl
+c
+cKE43
+c Initialisation pour la convection de K.E. (sb):
+         IF (iflag_con.GE.3) THEN
+
+         WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3  "
+         WRITE(lunout,*)
+     .      "On va utiliser le melange convectif des traceurs qui"
+         WRITE(lunout,*)"est calcule dans convect4.3"
+         WRITE(lunout,*)" !!! penser aux logical flags de phytrac"
+
+          DO i = 1, klon
+           ema_cbmf(i) = 0.
+           ema_pcb(i)  = 0.
+           ema_pct(i)  = 0.
+           ema_workcbmf(i) = 0.
+          ENDDO
+cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG
+          DO i = 1, klon
+           ibas_con(i) = 1
+           itop_con(i) = 1
+          ENDDO
+cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END
+c===============================================================================
+cCR:04.12.07: initialisations poches froides
+c Controle de ALE et ALP pour la fermeture convective (jyg)
+          if (iflag_wake.eq.1) then
+            CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr
+     s                  ,alp_bl_prescr, ale_bl_prescr)
+c 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU)
+c        print*,'apres ini_wake iflag_cldcon=', iflag_cldcon
+          endif
+
+        do i = 1,klon
+         Ale_bl(i)=0.
+         Alp_bl(i)=0.
+        enddo
+
+c================================================================================
+
+         ENDIF
+
+           rugoro=0.
+c34EK
+         IF (ok_orodr) THEN
+
+           rugoro=0.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH sans doute a enlever de finitivement ou, si on le garde, l'activer
+! justement quand ok_orodr = false.
+! ce rugoro est utilise par la couche limite et fait double emploi
+! avec les paramétrisations spécifiques de Francois Lott.
+!           DO i=1,klon
+!             rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+!           ENDDO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+           CALL SUGWD(klon,klev,paprs,pplay)
+           DO i=1,klon
+             zuthe(i)=0.
+             zvthe(i)=0.
+             if(zstd(i).gt.10.)then
+               zuthe(i)=(1.-zgam(i))*cos(zthe(i))
+               zvthe(i)=(1.-zgam(i))*sin(zthe(i))
+             endif
+           ENDDO
+         ENDIF
+c
+c
+         lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
+         WRITE(lunout,*)'La frequence de lecture surface est de ', 
+     .                   lmt_pas
+c
+cIM200505        ecrit_mth = NINT(86400./dtime *ecritphy)  ! tous les ecritphy jours
+c        IF (ok_mensuel) THEN
+c        WRITE(lunout,*)'La frequence de sortie mensuelle est de ', 
+c    .                   ecrit_mth
+c        ENDIF
+c        ecrit_day = NINT(86400./dtime *1.0)  ! tous les jours
+c        IF (ok_journe) THEN
+c        WRITE(lunout,*)'La frequence de sortie journaliere est de ',
+c    .                   ecrit_day
+c        ENDIF
+cIM 130904 BEG
+cIM 080205      ecrit_hf = 86400./dtime *0.25  ! toutes les 6h
+cIM 170305      
+c        ecrit_hf = 86400./dtime/12.  ! toutes les 2h
+cIM 230305      
+cIM200505        ecrit_hf = 86400./dtime *0.25  ! toutes les 6h
+c
+cIM200505        ecrit_hf2mth = ecrit_day/ecrit_hf*30
+c
+cIM200505        IF (ok_journe) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie hf est de ',
+cIM200505    .                   ecrit_hf
+cIM200505        ENDIF
+cIM 130904 END
+ccc         ecrit_ins = NINT(86400./dtime *0.5)  ! 2 fois par jour
+ccc         ecrit_ins = NINT(86400./dtime *0.25)  ! 4 fois par jour
+c        ecrit_ins = NINT(86400./dtime/48.)  ! a chaque pas de temps ==> PB. dans time_counter pour 1mois
+c        ecrit_ins = NINT(86400./dtime/12.)  ! toutes les deux heures
+cIM200505        ecrit_ins = NINT(86400./dtime/8.)  ! toutes les trois heures
+cIM200505        IF (ok_instan) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie instant. est de ', 
+cIM200505    .                   ecrit_ins
+cIM200505        ENDIF
+cIM200505        ecrit_reg = NINT(86400./dtime *0.25)  ! 4 fois par jour
+cIM200505        IF (ok_region) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie region est de ', 
+cIM200505    .                   ecrit_reg
+cIM200505        ENDIF
+cIM 030306 BEG
+cIM ecrit_hf2mth = nombre de pas de temps de calcul de hf par mois apres lequel on ecrit
+cIM : ne pas modifier ecrit_hf2mth
+c
+cIM 250308bad guide        ecrit_hf2mth = 30*1/ecrit_hf 
+         ecrit_hf2mth = ecrit_mth/ecrit_hf 
+c ecrit_ins en secondes, chaque pas de temps de la physique
+         ecrit_ins = dtime
+cIM on passe les frequences de jours en secondes : ecrit_ins, ecrit_hf, ecrit_day, ecrit_mth, ecrit_tra, ecrit_reg
+         ecrit_hf = ecrit_hf * un_jour
+!IM
+         IF(ecrit_day.LE.1.) THEN
+          ecrit_day = ecrit_day * un_jour !en secondes
+         ENDIF
+!IM
+         ecrit_mth = ecrit_mth * un_jour
+         ecrit_reg = ecrit_reg * un_jour
+         ecrit_tra = ecrit_tra * un_jour
+         ecrit_ISCCP = ecrit_ISCCP * un_jour
+c
+         PRINT*,'physiq ecrit_ hf day mth reg tra ISCCP hf2mth',
+     .   ecrit_hf,ecrit_day,ecrit_mth,ecrit_reg,ecrit_tra,ecrit_ISCCP,
+     .   ecrit_hf2mth
+cIM 030306 END
+
+      capemaxcels = 't_max(X)'
+      t2mincels = 't_min(X)'
+      t2maxcels = 't_max(X)'
+      tinst = 'inst(X)'
+      tave = 'ave(X)'
+cIM cf. AM 081204 BEG
+      write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con
+cIM cf. AM 081204 END
+c
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+
+c Commente par abderrahmane 11 2 08
+c#ifdef histhf
+c#include "ini_histhf.h"
+c#endif
+
+c#ifdef histday
+c#include "ini_histday.h"
+cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+c#include "ini_bilKP_ins.h"
+c#include "ini_bilKP_ave.h"
+c#endif
+
+c#ifdef histmth
+c#include "ini_histmth.h"
+c#endif
+
+c#ifdef histins
+c#include "ini_histins.h"
+c#endif
+
+       call phys_output_open(jjmp1,nqmax,nlevSTD,clevSTD,nbteta, 
+     &                        ctetaSTD,dtime,presnivs,ok_veget,
+     &                        ocean,iflag_pbl,ok_mensuel,ok_journe,
+     &                        ok_hf,ok_instan,nid_files)
+
+#ifdef histISCCP
+#include "ini_histISCCP.h"
+#endif
+
+#ifdef histmthNMC
+#include "ini_histmthNMC.h"
+#endif
+
+#include "ini_histday_seri.h"
+
+#include "ini_paramLMDZ_phy.h"
+
+#endif
+
+cXXXPB Positionner date0 pour initialisation de ORCHIDEE
+      date0 = zjulian
+C      date0 = day_ini
+      WRITE(*,*) 'physiq date0 : ',date0
+c
+c
+c
+c Prescrire l'ozone dans l'atmosphere
+c
+c
+cc         DO i = 1, klon
+cc         DO k = 1, klev
+cc            CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
+cc         ENDDO
+cc         ENDDO
+c
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         CALL VTe(VTphysiq)
+         CALL VTb(VTinca)
+         iii = MOD(NINT(xjour),360)
+         calday = FLOAT(iii) + gmtime
+         WRITE(lunout,*) 'initial time ', xjour, calday
+
+         CALL chemini( 
+     $                   rg,
+     $                   ra,
+     $                   airephy,
+     $                   rlat,
+     $                   rlon,
+     $                   presnivs,
+     $                   calday,
+     $                   klon,
+     $                   nqmax,
+     $                   pdtphys,
+     $                   annee_ref,
+     $                   day_ini)
+
+         CALL VTe(VTinca)
+         CALL VTb(VTphysiq)
+#endif
+      END IF
+c
+      ENDIF
+c
+c   ****************     Fin  de   IF ( debut  )   ***************
+c
+
+! Tendances bidons pour les processus qui n'affectent pas certaines
+! variables.
+      du0(:,:)=0.
+      dv0(:,:)=0.
+      dq0(:,:)=0.
+      dql0(:,:)=0.
+c
+c Mettre a zero des variables de sortie (pour securite)
+c
+      DO i = 1, klon
+         d_ps(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO iq = 1, nqmax
+      DO k = 1, klev
+      DO i = 1, klon
+         d_qx(i,k,iq) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+      da(:,:)=0.
+      mp(:,:)=0.
+      phi(:,:,:)=0.
+c
+c Ne pas affecter les valeurs entrees de u, v, h, et q
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k)  = t(i,k)
+         u_seri(i,k)  = u(i,k)
+         v_seri(i,k)  = v(i,k)
+         q_seri(i,k)  = qx(i,k,ivap)
+         ql_seri(i,k) = qx(i,k,iliq)
+         qs_seri(i,k) = 0.
+      ENDDO
+      ENDDO
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         tr_seri(i,k,iq-2) = qx(i,k,iq)
+      ENDDO
+      ENDDO
+      ENDDO
+      ELSE
+      DO k = 1, klev
+      DO i = 1, klon
+         tr_seri(i,k,1) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+        ztsol(i) = 0.
+      ENDDO
+      DO nsrf = 1, nbsrf
+        DO i = 1, klon
+          ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+        ENDDO
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after dynamic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol+d_h_vcol_phy, d_qt, 0.
+     s      , fs_bound, fq_bound )
+      END IF 
+
+c Diagnostiquer la tendance dynamique
+c
+      IF (ancien_ok) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime
+            d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime
+         ENDDO
+         ENDDO
+      ELSE
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = 0.0
+            d_q_dyn(i,k) = 0.0
+         ENDDO
+         ENDDO
+         ancien_ok = .TRUE.
+      ENDIF
+c
+c Ajouter le geopotentiel du sol:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zphi(i,k) = pphi(i,k) + pphis(i)
+      ENDDO
+      ENDDO
+c
+c Verifier les temperatures
+c
+cIM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+c
+       PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+cIM END
+c
+      CALL hgardfou(t_seri,ftsol,'debutphy')
+c
+cIM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+c
+       PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+cIM END
+c
+c Incrementer le compteur de la physique
+c
+      itap   = itap + 1
+      julien = MOD(NINT(xjour),360)
+      if (julien .eq. 0) julien = 360
+c
+c Mettre en action les conditions aux limites (albedo, sst, etc.).
+c Prescrire l'ozone et calculer l'albedo sur l'ocean.
+c
+      IF (MOD(itap-1,lmt_pas) .EQ. 0) THEN
+         WRITE(lunout,*)' PHYS cond  julien ',julien
+         CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
+      ENDIF
+c
+c Re-evaporer l'eau liquide nuageuse
+c
+      DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+c        zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+         zb = MAX(0.0,ql_seri(i,k))
+         za = - MAX(0.0,ql_seri(i,k))
+     .                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         t_seri(i,k) = t_seri(i,k) + za
+         q_seri(i,k) = q_seri(i,k) + zb
+         ql_seri(i,k) = 0.0
+         d_t_eva(i,k) = za
+         d_q_eva(i,k) = zb
+      ENDDO
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after reevap'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      END IF 
+
+c
+c=========================================================================
+! Calculs de l'orbite.
+! Necessaires pour le rayonnement et la surface (calcul de l'albedo).
+! doit donc etre placé avant radlwsw et pbl_surface
+
+!   choix entre calcul de la longitude solaire vraie ou valeur fixee a
+!   solarlong0
+
+      if (solarlong0<-999.) then
+         CALL orbite(FLOAT(julien),zlongi,dist)
+      else
+         zlongi=solarlong0  ! longitude solaire vraie
+         dist=1.            ! distance au soleil / moyenne
+      endif
+
+      if(prt_level.ge.1) print*,'Longitude solaire ',zlongi,solarlong0
+
+!  Avec ou sans cycle diurne
+      IF (cycle_diurne) THEN
+        zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
+        CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
+      ELSE
+        rmu0 = -999.999
+      ENDIF
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Appel au pbl_surface : Planetary Boudary Layer et Surface
+c Cela implique tous les interactions des sous-surfaces et la partie diffusion 
+c turbulent du couche limit. 
+c 
+c Certains varibales de sorties de pbl_surface sont utiliser que pour 
+c ecriture des fihiers hist_XXXX.nc, ces sont :
+c   qsol,      zq2m,      s_pblh,  s_lcl,
+c   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+c   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+c   zxrugs,    zu10m,     zv10m,   fder,
+c   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+c   frugs,     agesno,    fsollw,  fsolsw,
+c   d_ts,      fevap,     fluxlat, t2m,
+c   wfbils,    wfbilo,    fluxt,   fluxu, fluxv,
+c
+c Certains ne sont pas utiliser du tout : 
+c   dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
+c
+
+      CALL pbl_surface( 
+     e     dtime,     date0,     itap,    julien,
+     e     debut,     lafin,
+     e     rlon,      rlat,      rugoro,  rmu0,     
+     e     rain_fall, snow_fall, solsw,   sollw,    
+     e     t_seri,    q_seri,    u_seri,  v_seri,   
+     e     pplay,     paprs,     pctsrf,            
+     +     ftsol,     falb1,     falb2,   u10m,   v10m,
+     s     sollwdown, cdragh,    cdragm,  yu1,    yv1,
+     s     albsol1,   albsol2,   sens,    evap,  
+     s     zxtsol,    zxfluxlat, zt2m,    qsat2m, 
+     s     d_t_vdf,   d_q_vdf,   d_u_vdf, d_v_vdf,
+     s     ycoefh,    pctsrf_new,                
+     d     qsol,      zq2m,      s_pblh,  s_lcl,
+     d     s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+     d     s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+     d     zxrugs,    zu10m,     zv10m,   fder,
+     d     zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+     d     frugs,     agesno,    fsollw,  fsolsw,
+     d     d_ts,      fevap,     fluxlat, t2m,
+     d     wfbils,    wfbilo,    fluxt,   fluxu,  fluxv,
+     -     dsens,     devap,     zxsnow,
+     -     zxfluxt,   zxfluxq,   q2m,     fluxq, pbl_tke )
+c
+c
+      pctsrf(:,:) = pctsrf_new(:,:)
+      
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la diffusion turbulente
+      CALL add_phys_tend(d_u_vdf,d_v_vdf,d_t_vdf,d_q_vdf,dql0,'vdf')
+!-----------------------------------------------------------------------------------------
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after surface_main'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, sens
+     e      , evap  , zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+
+c =================================================================== c
+c   Calcul de Qsat
+
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+      if (prt_level.ge.1) then
+      write(lunout,*) 'L   qsat (g/kg) avant clouds_gno'
+      write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev)
+      endif
+c
+c Appeler la convection (au choix)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         conv_q(i,k) = d_q_dyn(i,k) 
+     .               + d_q_vdf(i,k)/dtime
+         conv_t(i,k) = d_t_dyn(i,k) 
+     .               + d_t_vdf(i,k)/dtime
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*) "avantcon=", za
+      ENDIF
+      zx_ajustq = .FALSE.
+      IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
+      IF (zx_ajustq) THEN
+         DO i = 1, klon
+            z_avant(i) = 0.0
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+            z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k))
+     .                        *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDDO
+         ENDDO
+      ENDIF
+
+c Calcule de vitesse verticale a partir de flux de masse verticale
+      DO k = 1, klev
+         DO i = 1, klon
+            omega(i,k) = RG*flxmass_w(i,k) / airephy(i)
+         END DO
+      END DO
+
+      IF (iflag_con.EQ.1) THEN
+          stop'reactiver le call conlmd dans physiq.F'
+c     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
+c    .             d_t_con, d_q_con,
+c    .             rain_con, snow_con, ibas_con, itop_con)
+      ELSE IF (iflag_con.EQ.2) THEN
+      CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
+     e            conv_t, conv_q, -evap, omega,
+     s            d_t_con, d_q_con, rain_con, snow_con,
+     s            pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s            kcbot, kctop, kdtop, pmflxr, pmflxs)
+      WHERE (rain_con < 0.) rain_con = 0.
+      WHERE (snow_con < 0.) snow_con = 0.
+      DO i = 1, klon
+         ibas_con(i) = klev+1 - kcbot(i)
+         itop_con(i) = klev+1 - kctop(i)
+      ENDDO
+      ELSE IF (iflag_con.GE.3) THEN
+c nb of tracers for the KE convection:
+c MAF la partie traceurs est faite dans phytrac
+c on met ntra=1 pour limiter les appels mais on peut
+c supprimer les calculs / ftra.
+              ntra = 1
+
+c=====================================================================================
+cajout pour la parametrisation des poches froides: 
+ccalcul de t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri 
+      do k=1,klev
+            do i=1,klon
+             if (iflag_wake.eq.1) then
+             t_wake(i,k) = t_seri(i,k)
+     .           +(1-wake_s(i))*wake_deltat(i,k)
+             q_wake(i,k) = q_seri(i,k)
+     .           +(1-wake_s(i))*wake_deltaq(i,k)
+             t_undi(i,k) = t_seri(i,k)
+     .           -wake_s(i)*wake_deltat(i,k)
+             q_undi(i,k) = q_seri(i,k)
+     .           -wake_s(i)*wake_deltaq(i,k)
+             else
+             t_wake(i,k) = t_seri(i,k)
+             q_wake(i,k) = q_seri(i,k)
+             t_undi(i,k) = t_seri(i,k)
+             q_undi(i,k) = q_seri(i,k)
+             endif
+            enddo
+         enddo
+      
+cc--   Calcul de l'energie disponible ALE (J/kg) et de la puissance disponible ALP (W/m2)
+cc--    pour le soulevement des particules dans le modele convectif
+c
+      do i = 1,klon
+        ALE(i) = 0.
+        ALP(i) = 0.
+      enddo
+c
+ccalcul de ale_wake et alp_wake
+       do i = 1,klon
+          if (iflag_wake.eq.1) then
+          ale_wake(i) = 0.5*wake_cstar(i)**2
+          alp_wake(i) = wake_fip(i)
+          else
+          ale_wake(i) = 0.
+          alp_wake(i) = 0.
+          endif
+       enddo
+ccombinaison avec ale et alp de couche limite: constantes si pas de couplage, valeurs calculees
+cdans le thermique sinon
+       if (iflag_coupl.eq.0) then
+          if (debut) print*,'ALE et ALP imposes'
+          do i = 1,klon
+con ne couple que ale
+c           ALE(i) = max(ale_wake(i),Ale_bl(i))
+            ALE(i) = max(ale_wake(i),ale_bl_prescr)
+con ne couple que alp
+c           ALP(i) = alp_wake(i) + Alp_bl(i)
+            ALP(i) = alp_wake(i) + alp_bl_prescr
+          enddo
+       else
+         IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique'
+          do i = 1,klon
+              ALE(i) = max(ale_wake(i),Ale_bl(i))
+              ALP(i) = alp_wake(i) + Alp_bl(i)
+c         write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i)
+c         write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i)
+          enddo
+       endif
+       do i=1,klon
+          if (alp(i)>alp_max) then
+             print*,'WARNING SUPER ALP (seuil=',alp_max,
+     ,       '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i)
+             alp(i)=alp_max
+          endif
+          if (ale(i)>ale_max) then
+             print*,'WARNING SUPER ALE (seuil=',ale_max,
+     ,       '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i)
+             ale(i)=ale_max
+          endif
+       enddo
+
+cfin calcul ale et alp
+c=================================================================================================
+
+
+c sb, oct02:
+c Schema de convection modularise et vectorise:
+c (driver commun aux versions 3 et 4)
+c
+          IF (ok_cvl) THEN ! new driver for convectL
+
+          CALL concvl (iflag_con,iflag_clos,
+     .        dtime,paprs,pplay,t_undi,q_undi,
+     .        t_wake,q_wake,
+     .        u_seri,v_seri,tr_seri,nbtr,
+     .        ALE,ALP,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con, sigd,
+     .        upwd,dnwd,dnwd0,
+     .        Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl,
+     .        pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd,
+     .        pmflxr,pmflxs,da,phi,mp,
+     .        ftd,fqd,lalim_conv,wght_th)
+
+cIM begin
+        print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1),
+     .dnwd0(1,1),ftd(1,1),fqd(1,1)
+cIM end
+cIM cf. FH
+              clwcon0=qcondc
+              pmfu(:,:)=upwd(:,:)+dnwd(:,:)
+
+          ELSE ! ok_cvl
+c MAF conema3 ne contient pas les traceurs
+          CALL conema3 (dtime,
+     .        paprs,pplay,t_seri,q_seri,
+     .        u_seri,v_seri,tr_seri,ntra,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,bas,top,
+     .        Ma,cape,tvp,rflag,
+     .        pbase
+     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr
+     .        ,clwcon0)
+
+          ENDIF ! ok_cvl
+
+c
+c Correction precip
+          rain_con = rain_con * cvl_corr
+          snow_con = snow_con * cvl_corr
+c
+
+           IF (.NOT. ok_gust) THEN
+           do i = 1, klon
+            wd(i)=0.0
+           enddo
+           ENDIF
+
+c =================================================================== c
+c Calcul des proprietes des nuages convectifs
+c
+
+c   calcul des proprietes des nuages convectifs
+             clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
+             call clouds_gno
+     s       (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
+
+c =================================================================== c
+
+          DO i = 1, klon
+            ema_pcb(i)  = pbase(i)
+          ENDDO
+          DO i = 1, klon
+
+! L'idicage de itop_con peut cacher un pb potentiel
+! FH sous la dictee de JYG, CR
+            ema_pct(i)  = paprs(i,itop_con(i)+1)
+
+            if (itop_con(i).gt.klev-3) then
+               print*,'La convection monte trop haut '
+               print*,'itop_con(,',i,',)=',itop_con(i)
+            endif
+          ENDDO
+          DO i = 1, klon
+            ema_cbmf(i) = ema_workcbmf(i)
+          ENDDO      
+      ELSE IF (iflag_con.eq.0) THEN
+          write(lunout,*) 'On n appelle pas la convection'
+          clwcon0=0.
+          rnebcon0=0.
+          d_t_con=0.
+          d_q_con=0.
+          d_u_con=0.
+          d_v_con=0.
+          rain_con=0.
+          snow_con=0.
+          bas=1
+          top=1
+      ELSE
+          WRITE(lunout,*) "iflag_con non-prevu", iflag_con
+          CALL abort
+      ENDIF
+
+c     CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
+c    .              d_u_con, d_v_con)
+
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la diffusion turbulente
+      CALL add_phys_tend(d_u_con,d_v_con,d_t_con,d_q_con,dql0,'con')
+!-----------------------------------------------------------------------------------------
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after convect'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_con, snow_con, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+C
+      IF (check) THEN
+          za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+          WRITE(lunout,*)"aprescon=", za
+          zx_t = 0.0
+          za = 0.0
+          DO i = 1, klon
+            za = za + airephy(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_con(i)+
+     .                   snow_con(i))*airephy(i)/FLOAT(klon)
+          ENDDO
+          zx_t = zx_t/za*dtime
+          WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+      IF (zx_ajustq) THEN
+          DO i = 1, klon
+            z_apres(i) = 0.0
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k))
+     .            *(paprs(i,k)-paprs(i,k+1))/RG
+            ENDDO
+          ENDDO
+          DO i = 1, klon
+            z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime)
+     .          /z_apres(i)
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              IF (z_factor(i).GT.(1.0+1.0E-08) .OR.
+     .            z_factor(i).LT.(1.0-1.0E-08)) THEN
+                  q_seri(i,k) = q_seri(i,k) * z_factor(i)
+              ENDIF
+            ENDDO
+          ENDDO
+      ENDIF
+      zx_ajustq=.FALSE.
+
+c
+c=============================================================================
+cRR:Evolution de la poche froide: on ne fait pas de separation wake/env 
+cpour la couche limite diffuse pour l instant
+c
+      if (iflag_wake.eq.1) then
+      DO k=1,klev
+        DO i=1,klon
+          dt_dwn(i,k)  = ftd(i,k) 
+          wdt_PBL(i,k) = 0.
+          dq_dwn(i,k)  = fqd(i,k) 
+          wdq_PBL(i,k) = 0.
+          M_dwn(i,k)   = dnwd0(i,k)
+          M_up(i,k)    = upwd(i,k)
+          dt_a(i,k)    = d_t_con(i,k)/dtime - ftd(i,k) 
+          udt_PBL(i,k) = 0.
+          dq_a(i,k)    = d_q_con(i,k)/dtime - fqd(i,k)
+          udq_PBL(i,k) = 0.
+        ENDDO
+      ENDDO
+c
+ccalcul caracteristiques de la poche froide
+      call calWAKE (paprs,pplay,dtime
+     :               ,t_seri,q_seri,omega
+     :               ,dt_dwn,dq_dwn,M_dwn,M_up
+     :               ,dt_a,dq_a,sigd
+     :               ,wdt_PBL,wdq_PBL
+     :               ,udt_PBL,udq_PBL
+     o               ,wake_deltat,wake_deltaq,wake_dth
+     o               ,wake_h,wake_s,wake_dens
+     o               ,wake_pe,wake_fip,wake_gfl
+     o               ,dt_wake,dq_wake
+     o               ,wake_k, t_undi,q_undi
+     o               ,wake_omgbdth,wake_dp_omgb
+     o               ,wake_dtKE,wake_dqKE
+     o               ,wake_dtPBL,wake_dqPBL
+     o               ,wake_omg,wake_dp_deltomg
+     o               ,wake_spread,wake_Cstar,wake_d_deltat_gw
+     o               ,wake_ddeltat,wake_ddeltaq)
+c
+!-----------------------------------------------------------------------------------------
+! ajout des tendances des poches froides
+! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake
+! coherent avec les autres d_t_...
+      d_t_wake(:,:)=dt_wake(:,:)*dtime
+      d_q_wake(:,:)=dq_wake(:,:)*dtime
+      CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,'wake')
+!-----------------------------------------------------------------------------------------
+
+      endif
+c      print*,'apres callwake iflag_cldcon=', iflag_cldcon
+c
+c===================================================================
+c Convection seche (thermiques ou ajustement)
+c===================================================================
+c
+       call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri
+     s ,seuil_inversion,weak_inversion,dthmin)
+
+
+
+      d_t_ajsb(:,:)=0.
+      d_q_ajsb(:,:)=0.
+      d_t_ajs(:,:)=0.
+      d_u_ajs(:,:)=0.
+      d_v_ajs(:,:)=0.
+      d_q_ajs(:,:)=0.
+      clwcon0th(:,:)=0.
+c
+      fm_therm(:,:)=0.
+      entr_therm(:,:)=0.
+      detr_therm(:,:)=0.
+c
+      IF(prt_level>9)WRITE(lunout,*)
+     .    'AVANT LA CONVECTION SECHE , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+      if(iflag_thermals.lt.0) then
+c  Rien
+c  ====
+         IF(prt_level>9)WRITE(lunout,*)'pas de convection'
+
+
+      else
+
+c  Thermiques
+c  ==========
+         IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+
+
+         if (iflag_thermals.gt.1) then
+         call calltherm(pdtphys
+     s      ,pplay,paprs,pphi,weak_inversion
+     s      ,u_seri,v_seri,t_seri,q_seri,zqsat,debut
+     s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
+     s      ,fm_therm,entr_therm,detr_therm
+     s      ,zqasc,clwcon0th,lmax_th,ratqscth
+     s      ,ratqsdiff,zqsatth
+con rajoute ale et alp, et les caracteristiques de la couche alim
+     s      ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0)
+         endif
+
+!        call calltherm(pdtphys
+!    s      ,pplay,paprs,pphi
+!    s      ,u_seri,v_seri,t_seri,q_seri
+!    s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
+!    s      ,fm_therm,entr_therm)
+
+c  Ajustement sec
+c  ==============
+
+! Dans le cas où on active les thermiques, on fait partir l'ajustement
+! a partir du sommet des thermiques.
+! Dans le cas contraire, on demarre au niveau 1.
+
+         if (iflag_thermals.ge.13.or.iflag_thermals.eq.0) then
+
+         if(iflag_thermals.eq.0) then
+            IF(prt_level>9)WRITE(lunout,*)'ajsec'
+            limbas(:)=1
+         else
+            limbas(:)=lmax_th(:)
+         endif
+  
+! Attention : le call ajsec_convV2 n'est maintenu que momentanneement
+! pour des test de convergence numerique.
+! Le nouveau ajsec est a priori mieux, meme pour le cas 
+! iflag_thermals = 0 (l'ancienne version peut faire des tendances
+! non nulles numeriquement pour des mailles non concernees.
+
+         if (iflag_thermals.eq.0) then
+            CALL ajsec_convV2(paprs, pplay, t_seri,q_seri
+     s      , d_t_ajsb, d_q_ajsb)
+         else
+            CALL ajsec(paprs, pplay, t_seri,q_seri,limbas
+     s      , d_t_ajsb, d_q_ajsb)
+         endif
+
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de l'ajustement sec ou des thermiques
+      CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,'ajsb')
+         d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
+         d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
+
+!-----------------------------------------------------------------------------------------
+
+         endif
+
+      endif
+c
+c===================================================================
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after dry_adjust'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+
+
+c-------------------------------------------------------------------------
+c  Caclul des ratqs
+c-------------------------------------------------------------------------
+
+c      print*,'calcul des ratqs'
+c   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
+c   ----------------
+c   on ecrase le tableau ratqsc calcule par clouds_gno
+      if (iflag_cldcon.eq.1) then
+         do k=1,klev
+         do i=1,klon
+            if(ptconv(i,k)) then
+              ratqsc(i,k)=ratqsbas
+     s        +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+            else
+               ratqsc(i,k)=0.
+            endif
+         enddo
+         enddo
+      else if (iflag_cldcon.eq.4) then
+         ptconvth(:,:)=.false.
+         ratqsc(:,:)=0.
+         if(prt_level.ge.9) print*,'avant clouds_gno thermique'
+         call clouds_gno
+     s   (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th)
+         if(prt_level.ge.9) print*,' CLOUDS_GNO OK'
+      endif
+
+c   ratqs stables
+c   -------------
+
+      if (iflag_ratqs.eq.0) then
+
+! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele.
+         do k=1,klev
+            do i=1, klon
+               ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s         min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) 
+            enddo 
+         enddo
+
+! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de 
+! 300 hPa (ratqshaut), varie lineariement en fonction de la pression
+! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1
+! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2
+! Il s'agit de differents tests dans la phase de reglage du modele
+! avec thermiques.
+
+      else if (iflag_ratqs.eq.1) then
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas
+               else if ((pplay(i,k).ge.30000.).and.
+     s            (pplay(i,k).lt.60000.)) then
+                  ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s            (60000.-pplay(i,k))/(60000.-30000.)
+               else
+                  ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+
+      else
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas
+     s            *(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.)
+               else if ((pplay(i,k).ge.30000.).and.
+     s             (pplay(i,k).lt.60000.)) then
+                    ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s              (60000.-pplay(i,k))/(60000.-30000.)
+               else
+                    ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+      endif
+
+
+
+
+c  ratqs final
+c  -----------
+
+      if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2
+     s    .or.iflag_cldcon.eq.4) then
+
+! On ajoute une constante au ratqsc*2 pour tenir compte de 
+! fluctuations turbulentes de petite echelle
+
+         do k=1,klev
+            do i=1,klon
+               if ((fm_therm(i,k).gt.1.e-10)) then
+                  ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2)
+               endif
+            enddo
+         enddo
+
+!   les ratqs sont une conbinaison de ratqss et ratqsc
+!   1800s, en dur pour le moment, est le temps de
+!   relaxation des ratqs
+
+         facteur=exp(-pdtphys/1800.)
+
+         print*,'WARNING ratqs a revoir '
+         ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur
+         ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2)
+
+      else
+!   on ne prend que le ratqs stable pour fisrtilp
+         ratqs(:,:)=ratqss(:,:)
+      endif
+
+
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c-------------------------------------------------------------------------
+      CALL fisrtilp(dtime,paprs,pplay,
+     .           t_seri, q_seri,ptconv,ratqs,
+     .           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq,
+     .           rain_lsc, snow_lsc,
+     .           pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     .           frac_impa, frac_nucl,
+     .           prfl, psfl, rhcl)
+
+      WHERE (rain_lsc < 0) rain_lsc = 0.
+      WHERE (snow_lsc < 0) snow_lsc = 0.
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la diffusion turbulente
+      CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,'lsc')
+!-----------------------------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         cldfra(i,k) = rneb(i,k)
+         IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*)"apresilp=", za
+         zx_t = 0.0
+         za = 0.0
+         DO i = 1, klon
+            za = za + airephy(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_lsc(i)
+     .                  + snow_lsc(i))*airephy(i)/FLOAT(klon)
+        ENDDO
+         zx_t = zx_t/za*dtime
+         WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after fisrt'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_lsc, snow_lsc, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+c
+c-------------------------------------------------------------------
+c  PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
+c-------------------------------------------------------------------
+
+c 1. NUAGES CONVECTIFS
+c
+cIM cf FH
+c     IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke
+      IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke
+       snow_tiedtke=0.
+c     print*,'avant calcul de la pseudo precip '
+c     print*,'iflag_cldcon',iflag_cldcon
+       if (iflag_cldcon.eq.-1) then
+          rain_tiedtke=rain_con
+       else
+c       print*,'calcul de la pseudo precip '
+          rain_tiedtke=0.
+c         print*,'calcul de la pseudo precip 0'
+          do k=1,klev
+          do i=1,klon
+             if (d_q_con(i,k).lt.0.) then
+                rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys
+     s         *(paprs(i,k)-paprs(i,k+1))/rg
+             endif
+          enddo
+          enddo
+       endif
+c
+c     call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ')
+c
+
+c Nuages diagnostiques pour Tiedtke
+      CALL diagcld1(paprs,pplay,
+cIM cf FH  .             rain_con,snow_con,ibas_con,itop_con,
+     .             rain_tiedtke,snow_tiedtke,ibas_con,itop_con,
+     .             diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+
+      ELSE IF (iflag_cldcon.ge.3) THEN
+c  On prend pour les nuages convectifs le max du calcul de la
+c  convection et du calcul du pas de temps precedent diminue d'un facteur
+c  facttemps
+      facteur = pdtphys *facttemps
+      do k=1,klev
+         do i=1,klon
+            rnebcon(i,k)=rnebcon(i,k)*facteur
+            if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k))
+     s      then
+                rnebcon(i,k)=rnebcon0(i,k)
+                clwcon(i,k)=clwcon0(i,k)
+            endif
+         enddo
+      enddo
+
+c
+cjq - introduce the aerosol direct and first indirect radiative forcings
+cjq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
+      IF (ok_ade.OR.ok_aie) THEN
+       IF ( .NOT. aerosol_couple ) THEN
+         ! Get sulfate aerosol distribution
+         CALL readsulfate(rjourvrai, debut, sulfate)
+         CALL readsulfate_preind(rjourvrai, debut, sulfate_pi)
+
+         ! Calculate aerosol optical properties (Olivier Boucher)
+         CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl,
+     .        tau_ae, piz_ae, cg_ae, aerindex)
+       ENDIF
+      ELSE
+        tau_ae(:,:,:)=0.0
+	piz_ae(:,:,:)=0.0
+	cg_ae(:,:,:)=0.0 
+      ENDIF
+
+c
+cIM calcul nuages par le simulateur ISCCP
+c
+#ifdef histISCCP
+      IF (ok_isccp) THEN
+cIM appel simulateur toutes les  NINT(freq_ISCCP/dtime) heures
+       IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN
+#include "calcul_simulISCCP.h"
+       ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime))
+      ENDIF !ok_isccp
+#endif
+
+c   On prend la somme des fractions nuageuses et des contenus en eau
+      cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+      cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
+
+      ENDIF
+
+c
+c 2. NUAGES STARTIFORMES
+c
+      IF (ok_stratus) THEN
+      CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Precipitation totale
+c
+      DO i = 1, klon
+         rain_fall(i) = rain_con(i) + rain_lsc(i)
+         snow_fall(i) = snow_con(i) + snow_lsc(i)
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit="after diagcld"
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c Calculer l'humidite relative pour diagnostique
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zx_rh(i,k) = q_seri(i,k)/zx_qs
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+cIM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 
+c   equivalente a 2m (tpote) pour diagnostique
+c
+      DO i = 1, klon
+       tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA
+       IF (thermcep) THEN
+        IF(zt2m(i).LT.RTT) then
+	 Lheat=RLSTT
+	ELSE
+	 Lheat=RLVTT
+        ENDIF
+       ELSE
+        IF (zt2m(i).LT.RTT) THEN
+         Lheat=RLSTT
+        ELSE
+	 Lheat=RLVTT
+        ENDIF
+       ENDIF
+       tpote(i) = tpot(i)*     
+     . EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i)))
+      ENDDO
+
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         CALL VTe(VTphysiq)
+         CALL VTb(VTinca)
+         calday = FLOAT(julien) + gmtime
+
+         IF (config_inca == 'aero') THEN
+            CALL AEROSOL_METEO_CALC(calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs
+     &           ,prfl,psfl,pctsrf,airephy,xjour,rlat,rlon,u10m,v10m)
+         END IF
+
+         zxsnow_dummy(:) = 0.0
+
+         CALL chemhook_begin (calday,
+     $                          julien,
+     $                          gmtime,
+     $                          pctsrf(1,1),
+     $                          rlat,
+     $                          rlon,
+     $                          airephy,
+     $                          paprs,
+     $                          pplay,
+     $                          ycoefh,
+     $                          pphi,
+     $                          t_seri,
+     $                          u,
+     $                          v,
+     $                          wo,
+     $                          q_seri,
+     $                          zxtsol,
+     $                          zxsnow_dummy,
+     $                          solsw,
+     $                          albsol1,
+     $                          rain_fall,
+     $                          snow_fall,
+     $                          itop_con,
+     $                          ibas_con,
+     $                          cldfra,
+     $                          iim,
+     $                          jjm,
+     $                          tr_seri,
+     $                          ftsol,
+     $                          paprs,
+     $                          cdragh,
+     $                          cdragm,
+     $                          pctsrf,
+     $				pdtphys,
+     $				itap)
+
+         CALL VTe(VTinca)
+         CALL VTb(VTphysiq)
+#endif 
+      END IF !config_inca /= 'none'
+c     
+c Calculer les parametres optiques des nuages et quelques
+c parametres pour diagnostiques:
+c
+
+      IF (aerosol_couple) THEN 
+         sulfate(:,:) = ccm(:,:,1) 
+         sulfate_pi(:,:) = ccm(:,:,2) 
+      ENDIF
+
+      if (ok_newmicro) then
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq,
+     .            flwp, fiwp, flwc, fiwc,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+      else
+      CALL nuage (paprs, pplay,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+      
+      endif
+c
+c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
+c
+      IF (MOD(itaprad,radpas).EQ.0) THEN
+
+      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
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+      IF (aerosol_couple) THEN 
+#ifdef INCA
+      CALL radlwsw_inca 
+     e            (kdlon,kflev,dist, rmu0, fract, solaire,
+     e             paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
+     e             wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             lwdn0, lwdn, lwup0, lwup, 
+     s             swdn0, swdn, swup0, swup,
+     e             ok_ade, ok_aie,
+     e             tau_inca, piz_inca, cg_inca,
+     s             topswad_inca, solswad_inca,
+     s             topswad0_inca, solswad0_inca,
+     s             topsw_inca, topsw0_inca,
+     s             solsw_inca, solsw0_inca,
+     e             cldtaupi,
+     s             topswai_inca, solswai_inca)
+#endif
+      ELSE
+      CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS)
+     e            (dist, rmu0, fract, 
+     e             paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri,
+     e             wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             lwdn0, lwdn, lwup0, lwup, 
+     s             swdn0, swdn, swup0, swup,
+     e             ok_ade, ok_aie, ! new for aerosol radiative effects
+     e             tau_ae, piz_ae, cg_ae, ! ="=
+     s             topswad, solswad, ! ="=
+     e             cldtaupi, ! ="=
+     s             topswai, solswai) ! ="=
+      ENDIF
+      itaprad = 0
+      ENDIF
+      itaprad = itaprad + 1
+
+      if (iflag_radia.eq.0) then
+      print *,'--------------------------------------------------'
+      print *,'>>>> ATTENTION rayonnement desactive pour ce cas'
+      print *,'>>>>           heat et cool mis a zero '
+      print *,'--------------------------------------------------'
+      heat=0.
+      cool=0.
+      endif
+
+
+c
+c Ajouter la tendance des rayonnements (tous les pas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k)
+     .               + (heat(i,k)-cool(i,k)) * dtime/86400.
+      ENDDO
+      ENDDO
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+ 
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after rad'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , topsw, toplw, solsw, sollw, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+c
+c
+c Calculer l'hydrologie de la surface
+c
+c      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
+c     .            agesno, ftsol,fqsurf,fsnow, ruis)
+c
+
+c
+c Calculer le bilan du sol et la derive de temperature (couplage)
+c
+      DO i = 1, klon
+c         bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
+c a la demande de JLD
+         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
+      ENDDO
+c
+cmoddeblott(jan95)
+c Appeler le programme de parametrisation de l'orographie
+c a l'echelle sous-maille:
+c
+      IF (ok_orodr) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+c        IF ((zstd(i).gt.10.0)) THEN
+        IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL drag_noro(klon,klev,dtime,paprs,pplay,
+     e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,idx,itest,
+     e                   t_seri, u_seri, v_seri,
+cIM 141004    s                   zulow, zvlow, zustr, zvstr,
+     s                   zulow, zvlow, zustrdr, zvstrdr,
+     s                   d_t_oro, d_u_oro, d_v_oro)
+c
+c  ajout des tendances
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la trainee de l'orographie
+      CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,'oro')
+!-----------------------------------------------------------------------------------------
+c
+      ENDIF ! fin de test sur ok_orodr
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+      IF (ok_orolf) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+        IF ((zpic(i)-zmea(i)).GT.100.) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL lift_noro(klon,klev,dtime,paprs,pplay,
+     e                   rlat,zmea,zstd,zpic,
+     e                   itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustrli, zvstrli,
+     s                   d_t_lif, d_u_lif, d_v_lif)
+c
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la portance de l'orographie
+      CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,'lif')
+!-----------------------------------------------------------------------------------------
+c
+      ENDIF ! fin de test sur ok_orolf
+c
+cIM cf. FLott BEG
+C STRESS NECESSAIRES: TOUTE LA PHYSIQUE
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO i = 1, klon
+        zustrph(i)=0.
+        zvstrph(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+       zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime*
+     c            (paprs(i,k)-paprs(i,k+1))/rg
+       zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime*
+     c            (paprs(i,k)-paprs(i,k+1))/rg
+      ENDDO
+      ENDDO
+c
+cIM calcul composantes axiales du moment angulaire et couple des montagnes
+c
+      IF (is_sequential) THEN
+      
+        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+     C                 ra,rg,romega,
+     C                 rlat,rlon,pphis,
+     C                 zustrdr,zustrli,zustrph,
+     C                 zvstrdr,zvstrli,zvstrph,
+     C                 paprs,u,v,
+     C                 aam, torsfc)
+       ENDIF
+cIM cf. FLott END
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after orography'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c
+cAA
+cAA Installation de l'interface online-offline pour traceurs
+cAA
+c====================================================================
+c   Calcul  des tendances traceurs
+c====================================================================
+C
+      IF (config_inca /= 'none') rnpb=.FALSE.
+
+      call phytrac (     rnpb,
+     I                   itap, 
+     I                   julien, 
+     I                   gmtime,
+     I                   debut,
+     I                   lafin,
+     I                   nqmax-2,
+     I                   nlon,
+     I                   nlev,
+     I                   dtime,
+     I                   u,
+     I                   v,
+     I                   t,
+     I                   paprs,
+     I                   pplay,
+     I                   pmfu, 
+     I                   pmfd, 
+     I                   pen_u, 
+     I                   pde_u, 
+     I                   pen_d, 
+     I                   pde_d,
+     I                   ycoefh,
+     I                   fm_therm,
+     I                   entr_therm,
+     I                   yu1,
+     I                   yv1,
+     I                   ftsol,
+     I                   pctsrf,
+     I                   rlat,
+     I                   frac_impa, 
+     I                   frac_nucl,
+     I                   rlon,
+     I                   presnivs,
+     I                   pphis,
+     I                   pphi,
+     I                   albsol1,
+     I                   qx(1,1,1), 
+     I                   rhcl,
+     I                   cldfra, 
+     I                   rneb, 
+     I                   diafra, 
+     I                   cldliq, 
+     I                   itop_con,
+     I                   ibas_con,
+     I                   pmflxr,
+     I                   pmflxs,
+     I                   prfl,
+     I                   psfl,
+     I                   da,
+     I                   phi,
+     I                   mp,
+     I                   upwd,
+     I                   dnwd,
+     I                   aerosol_couple,
+     I                   flxmass_w,
+     I                   tau_inca, 
+     I                   piz_inca, 
+     I                   cg_inca,
+     I                   ccm,
+     I                   rfname,
+     O                   tr_seri)
+
+      IF (offline) THEN
+
+         print*,'Attention on met a 0 les thermiques pour phystoke'
+	 call phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   fm_therm,entr_therm,
+     I                   ycoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa, frac_nucl,
+     I                   pphis,airephy,dtime,itap)
+
+
+      ENDIF
+
+c
+c Calculer le transport de l'eau et de l'energie (diagnostique)
+c
+      CALL transp (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve, vq, ue, uq)
+c
+cIM global posePB BEG
+      IF(1.EQ.0) THEN
+c
+      CALL transp_lay (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve_lay, vq_lay, ue_lay, uq_lay)
+c
+      ENDIF !(1.EQ.0) THEN
+cIM global posePB END
+c Accumuler les variables a stocker dans les fichiers histoire:
+c
+c+jld ec_conser
+      DO k = 1, klev
+      DO i = 1, klon
+        ZRCPD = RCPD*(1.0+RVTMP2*q_seri(i,k))
+        d_t_ec(i,k)=0.5/ZRCPD
+     $      *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2)
+        t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k)
+        d_t_ec(i,k) = d_t_ec(i,k)/dtime
+       END DO 
+      END DO 
+c-jld ec_conser
+cIM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after physic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , topsw, toplw, solsw, sollw, sens
+     e      , evap, rain_fall, snow_fall, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      d_h_vcol_phy=d_h_vcol
+C
+      END IF 
+C
+c=======================================================================
+c   SORTIES
+c=======================================================================
+
+cIM Interpolation sur les niveaux de pression du NMC
+c   -------------------------------------------------
+c
+#include "calcul_STDlev.h"
+c
+c slp sea level pressure
+      slp(:) = paprs(:,1)*exp(pphis(:)/(RD*t_seri(:,1)))
+c
+ccc prw = eau precipitable
+      DO i = 1, klon
+       prw(i) = 0.
+       DO k = 1, klev
+        prw(i) = prw(i) +
+     .           q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+       ENDDO
+      ENDDO
+c
+cIM initialisation + calculs divers diag AMIP2
+c
+#include "calcul_divers.h"
+c
+      IF (config_inca /= 'none') THEN
+#ifdef INCA
+         CALL VTe(VTphysiq)
+         CALL VTb(VTinca)
+
+         CALL chemhook_end (calday,
+     $                        dtime,
+     $                        pplay,
+     $                        t_seri,
+     $                        tr_seri,
+     $                        nbtr,
+     $                        paprs,
+     $                        q_seri,
+     $                        annee_ref,
+     $                        day_ini,
+     $                        airephy,
+     $                        xjour,
+     $                        pphi,
+     $                        pphis,
+     $                        zx_rh)
+     $                        xjour)
+
+         CALL VTe(VTinca)
+         CALL VTb(VTphysiq)
+#endif
+      END IF
+
+c=============================================================
+c
+c Convertir les incrementations en tendances
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
+         d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
+         d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
+         d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
+         d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
+      ENDDO
+      ENDDO
+c
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDIF
+c
+cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+cIM global posePB#include "write_bilKP_ins.h"
+cIM global posePB#include "write_bilKP_ave.h"
+c
+c Sauvegarder les valeurs de t et q a la fin de la physique:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_ancien(i,k) = t_seri(i,k)
+         q_ancien(i,k) = q_seri(i,k)
+      ENDDO
+      ENDDO
+c
+!==========================================================================
+! Sorties des tendances pour un point particulier
+! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier
+! pour le debug
+! La valeur de igout est attribuee plus haut dans le programme
+!==========================================================================
+
+      if (prt_level.ge.1) then
+      write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
+      write(lunout,*)
+     s 'nlon,nlev,nqmax,debut,lafin,rjourvrai,gmtime,pdtphys pct tlos'
+      write(lunout,*)
+     s  nlon,nlev,nqmax,debut,lafin,rjourvrai,gmtime,pdtphys,
+     s  pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce),
+     s  pctsrf(igout,is_sic)
+      write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva'
+      do k=1,nlev
+         write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k),
+     s   d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k),
+     s   d_t_eva(igout,k)
+      enddo
+      write(lunout,*) 'cool,heat'
+      do k=1,nlev
+         write(lunout,*) cool(igout,k),heat(igout,k)
+      enddo
+
+      write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec'
+      do k=1,nlev
+         write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k),
+     s d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k)
+      enddo
+
+      write(lunout,*) 'd_ps ',d_ps(igout)
+      write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 '
+      do k=1,nlev
+         write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k),
+     s  d_qx(igout,k,1),d_qx(igout,k,2)
+      enddo
+      endif
+
+!==========================================================================
+
+c============================================================
+c   Calcul de la temperature potentielle
+c============================================================
+      DO k = 1, klev
+      DO i = 1, klon
+        theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD)
+      ENDDO
+      ENDDO
+c
+
+c 22.03.04 BEG
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+#ifdef CPP_IOIPSL
+ 
+c Recupere des varibles calcule dans differents modules
+c pour ecriture dans histxxx.nc 
+
+      ! Get some variables from module fonte_neige_mod
+      CALL fonte_neige_get_vars(pctsrf, 
+     .     zxfqcalving, zxfqfonte, zxffonte)
+
+      IF (ocean == 'slab') THEN
+         ! Get some variables from module ocean_slab_mod
+         CALL ocean_slab_get_vars(tslab, seaice, fluxo, fluxg)
+      ELSEIF (ocean == 'couple') THEN
+         ! Get some variables from module ocean_cpl_mod
+         CALL ocean_cpl_get_vars(fluxo, fluxg)
+      ELSE 
+         ! Get some variables from module ocean_forced_mod
+         CALL ocean_forced_get_vars(fluxo, fluxg)
+      ENDIF
+
+
+c Commente par abderrahmane le 11 2 08
+c#ifdef histhf
+c#include "write_histhf.h"
+c#endif
+
+c#ifdef histday
+c#include "write_histday.h"
+c#endif
+
+c#ifdef histmth
+c#include "write_histmth.h"
+c#endif
+
+c#ifdef histins
+c#include "write_histins.h"
+c#endif
+
+#include "phys_output_write.h"
+
+#ifdef histISCCP
+#include "write_histISCCP.h"
+#endif
+
+#ifdef histmthNMC
+#include "write_histmthNMC.h"
+#endif
+
+#include "write_histday_seri.h"
+
+#include "write_paramLMDZ_phy.h"
+
+#endif
+
+c 22.03.04 END
+c
+c====================================================================
+c Si c'est la fin, il faut conserver l'etat de redemarrage
+c====================================================================
+c
+      
+
+      IF (lafin) THEN
+         itau_phy = itau_phy + itap
+         CALL phyredem ("restartphy.nc")
+         open(97,form="unformatted",file="finbin")
+         write(97) u_seri,v_seri,t_seri,q_seri
+         close(97)
+      ENDIF
+      
+
+      RETURN
+      END
+      FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
+      IMPLICIT none
+c
+c Calculer et imprimer l'eau totale. A utiliser pour verifier
+c la conservation de l'eau
+c
+#include "YOMCST.h"
+      INTEGER klon,klev
+      REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
+      REAL aire(klon)
+      REAL qtotal, zx, qcheck
+      INTEGER i, k
+c
+      zx = 0.0
+      DO i = 1, klon
+         zx = zx + aire(i)
+      ENDDO
+      qtotal = 0.0
+      DO k = 1, klev
+      DO i = 1, klon
+         qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i)
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+      ENDDO
+      ENDDO
+c
+      qcheck = qtotal/zx
+c
+      RETURN
+      END
+      SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+      IMPLICIT none
+c
+c Tranformer une variable de la grille physique a
+c la grille d'ecriture
+c
+      INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
+c
+      INTEGER i, n, ig
+c
+      jjm = jjmp1 - 1
+      DO n = 1, nfield
+         DO i=1,iim
+            ecrit(i,n) = fi(1,n)
+            ecrit(i+jjm*iim,n) = fi(nlon,n)
+         ENDDO
+         DO ig = 1, nlon - 2
+           ecrit(iim+ig,n) = fi(1+ig,n)
+         ENDDO
+      ENDDO
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phystokenc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phystokenc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phystokenc.F	(revision 984)
@@ -0,0 +1,430 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   pfm_therm,pentr_therm,
+     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa,frac_nucl,
+     I                   pphis,paire,dtime,itap)
+      USE ioipsl
+      USE dimphy
+      USE iophy
+      IMPLICIT none
+
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+
+c======================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "tracstoke.h"
+#include "indicesol.h"
+#include "control.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon ! nombre de points horizontaux
+      integer nlev ! nombre de couches verticales
+      real pdtphys ! pas d'integration pour la physique (seconde)
+c
+      integer physid, itap
+      save physid
+c$OMP THREADPRIVATE(physid)
+      integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
+
+c   convection:
+c   -----------
+c
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+      real pt(klon,klev)
+      REAL,allocatable,save :: t(:,:)
+c$OMP THREADPRIVATE(t)
+c
+      REAL rlon(klon), rlat(klon), dtime
+      REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
+
+c   Couche limite:
+c   --------------
+c
+      REAL pcoefh(klon,klev)    ! coeff melange CL
+      REAL yv1(klon)
+      REAL yu1(klon),pphis(klon),paire(klon)
+
+c   Les Thermiques : (Abderr 25 11 02)
+c   ---------------
+      REAL pfm_therm(klon,klev+1)
+      real fm_therm1(klon,klev)
+      REAL pentr_therm(klon,klev)
+    
+      REAL,allocatable,save :: entr_therm(:,:)
+      REAL,allocatable,save :: fm_therm(:,:)
+c$OMP THREADPRIVATE(entr_therm)
+c$OMP THREADPRIVATE(fm_therm)
+c
+c   Lessivage:
+c   ----------
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+c
+c Arguments necessaires pour les sources et puits de traceur
+C
+      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c======================================================================
+c
+      INTEGER i, k
+c
+      REAL,allocatable,save :: mfu(:,:)  ! flux de masse dans le panache montant
+      REAL,allocatable,save :: mfd(:,:)  ! flux de masse dans le panache descendant
+      REAL,allocatable,save :: en_u(:,:) ! flux entraine dans le panache montant
+      REAL,allocatable,save :: de_u(:,:) ! flux detraine dans le panache montant
+      REAL,allocatable,save :: en_d(:,:) ! flux entraine dans le panache descendant
+      REAL,allocatable,save :: de_d(:,:) ! flux detraine dans le panache descendant
+      REAL,allocatable,save :: coefh(:,:) ! flux detraine dans le panache descendant
+
+      REAL,allocatable,save :: pyu1(:)
+      REAL,allocatable,save :: pyv1(:)
+      REAL,allocatable,save :: pftsol(:,:)
+      REAL,allocatable,save :: ppsrf(:,:)
+c$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
+c$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
+      real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
+      real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
+
+      REAL dtcum
+
+      integer iadvtr,irec
+      real zmin,zmax
+      logical ok_sync
+ 
+      save dtcum
+      save iadvtr,irec
+c$OMP THREADPRIVATE(dtcum,iadvtr,irec)
+      data iadvtr,irec/0,1/
+      logical,save :: first=.true.
+c$OMP THREADPRIVATE(first)
+c
+c   Couche limite:
+c======================================================================
+
+      ok_sync = .true.
+	print*,'Dans phystokenc.F'
+      print*,'iadvtr= ',iadvtr
+      print*,'istphy= ',istphy
+      print*,'istdyn= ',istdyn
+
+      if (first) then
+      
+        allocate( t(klon,klev))
+        allocate( mfu(klon,klev))  
+        allocate( mfd(klon,klev))  
+        allocate( en_u(klon,klev)) 
+        allocate( de_u(klon,klev)) 
+        allocate( en_d(klon,klev)) 
+        allocate( de_d(klon,klev)) 
+        allocate( coefh(klon,klev)) 
+        allocate( entr_therm(klon,klev))
+        allocate( fm_therm(klon,klev))
+        allocate( pyu1(klon))
+        allocate( pyv1(klon))
+        allocate( pftsol(klon,nbsrf))
+        allocate( ppsrf(klon,nbsrf))
+  
+        first=.false.
+      endif
+      
+      IF (iadvtr.eq.0) THEN
+	
+	CALL initphysto('phystoke',
+     . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)
+  	
+	write(*,*) 'apres initphysto ds phystokenc' 
+
+	
+      ENDIF
+c
+      ndex2d = 0
+      ndex3d = 0
+      i=itap 
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(physid,"phis",i,pphis)
+c
+      i=itap
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+      CALL histwrite_phy(physid,"aire",i,paire)
+
+      iadvtr=iadvtr+1
+c
+      if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
+	print*,'reinitialisation des champs cumules 
+     s          a iadvtr=',iadvtr
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+                t(i,k)=0.
+		fm_therm(i,k)=0.
+               entr_therm(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+                t(i,k)=t(i,k)+pt(i,k)*pdtphys
+       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+
+      IF(mod(iadvtr,istphy).eq.0) THEN 
+c
+c   normalisation par le temps cumule
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=mfu(i,k)/dtcum
+               mfd(i,k)=mfd(i,k)/dtcum
+               en_u(i,k)=en_u(i,k)/dtcum
+               de_u(i,k)=de_u(i,k)/dtcum
+               en_d(i,k)=en_d(i,k)/dtcum
+               de_d(i,k)=de_d(i,k)/dtcum
+               coefh(i,k)=coefh(i,k)/dtcum
+c Unitel a enlever
+	      t(i,k)=t(i,k)/dtcum	
+               fm_therm(i,k)=fm_therm(i,k)/dtcum
+	       entr_therm(i,k)=entr_therm(i,k)/dtcum
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)/dtcum
+            pyu1(i)=pyu1(i)/dtcum
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)/dtcum
+               pftsol1(i) = pftsol(i,1)
+               pftsol2(i) = pftsol(i,2)
+               pftsol3(i) = pftsol(i,3)
+               pftsol4(i) = pftsol(i,4)
+
+               ppsrf(i,k)=ppsrf(i,k)/dtcum
+               ppsrf1(i) = ppsrf(i,1)
+               ppsrf2(i) = ppsrf(i,2)
+               ppsrf3(i) = ppsrf(i,3)
+               ppsrf4(i) = ppsrf(i,4)
+
+            enddo
+         enddo
+c
+c   ecriture des champs
+c
+         irec=irec+1
+
+ccccc
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
+         CALL histwrite_phy(physid,"t",itap,t)
+
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
+      CALL histwrite_phy(physid,"mfu",itap,mfu)
+cym	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
+      CALL histwrite_phy(physid,"mfd",itap,mfd)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_u",itap,en_u)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
+      CALL histwrite_phy(physid,"de_u",itap,de_u)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_d",itap,en_d)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)       
+      CALL histwrite_phy(physid,"de_d",itap,de_d)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)         
+      CALL histwrite_phy(physid,"coefh",itap,coefh)	
+
+c ajou...
+	do k=1,klev
+           do i=1,klon
+	 fm_therm1(i,k)=fm_therm(i,k)	
+	   enddo
+	enddo
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d)
+      CALL histwrite_phy(physid,"fm_th",itap,fm_therm1)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_th",itap,entr_therm)
+cccc
+cym       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
+        CALL histwrite_phy(physid,"frac_impa",itap,frac_impa)
+
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
+        CALL histwrite_phy(physid,"frac_nucl",itap,frac_nucl)
+ 
+cym        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
+      CALL histwrite_phy(physid,"pyu1",itap,pyu1)
+	
+cym	CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
+      CALL histwrite_phy(physid,"pyv1",itap,pyv1)
+	
+cym	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol1",itap,pftsol1)
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol2",itap,pftsol2)
+cym          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol3",itap,pftsol3)
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol4",itap,pftsol4)
+
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf1",itap,ppsrf1)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf2",itap,ppsrf2)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf3",itap,ppsrf3)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf4",itap,ppsrf4)
+
+c$OMP MASTER
+      if (ok_sync) call histsync(physid)
+c$OMP END MASTER
+c     if (ok_sync) call histsync
+	
+c
+cAA Test sur la valeur des coefficients de lessivage 
+c
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_nucl(i,k))
+                  zmin=min(zmin,frac_nucl(i,k))
+            enddo
+         enddo
+         Print*,'------ coefs de lessivage (min et max) --------'
+         Print*,'facteur de nucleation ',zmin,zmax
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_impa(i,k))
+                  zmin=min(zmin,frac_impa(i,k))
+            enddo
+         enddo
+         Print*,'facteur d impaction ',zmin,zmax
+
+      ENDIF 
+
+c   reinitialisation des champs cumules
+	go to 768
+      if (mod(iadvtr,istphy).eq.1) then
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+	       t(i,k)=0.
+               fm_therm(i,k)=0.
+	       entr_therm(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+		t(i,k)=t(i,k)+pt(i,k)*pdtphys
+       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+768   continue
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/phytrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/phytrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/phytrac.F	(revision 984)
@@ -0,0 +1,851 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phytrac (rnpb,
+     I                    nstep,
+     I                    julien,
+     I                    gmtime,
+     I                    debutphy,
+     I                    lafin,
+     I                    nqmax,
+     I                    nlon,
+     I                    nlev,
+     I                    pdtphys,
+     I                    u,
+     I                    v,
+     I                    t_seri,
+     I                    paprs,
+     I                    pplay,
+     I                    pmfu,
+     I                    pmfd,
+     I                    pen_u,
+     I                    pde_u,
+     I                    pen_d,
+     I                    pde_d,
+     I                    coefh,
+     I                    fm_therm,
+     I                    entr_therm,
+     I                    yu1,
+     I                    yv1,
+     I                    ftsol,
+     I                    pctsrf,
+     I                    xlat,
+     I                    frac_impa,
+     I                    frac_nucl,
+     I                    xlon,
+     I                    presnivs,
+     I                    pphis,
+     I                    pphi,
+     I                    albsol,
+     I                    sh,
+     I                    rh,
+     I                    cldfra,
+     I                    rneb,
+     I                    diafra,
+     I                    cldliq,
+     I                    itop_con,
+     I                    ibas_con,
+     I                    pmflxr,
+     I                    pmflxs,
+     I                    prfl,
+     I                    psfl,
+     I                    da,
+     I                    phi,
+     I                    mp,
+     I                    upwd,
+     I                    dnwd,
+     I                    aerosol_couple,
+     I                    flxmass_w,
+     I                    tau_inca, 
+     I                    piz_inca, 
+     I                    cg_inca,
+     I                    ccm,
+     I                    rfname,
+     O                    tr_seri)
+
+      USE ioipsl
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE comgeomphy
+      USE iophy
+      USE vampir
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+cAA Remarques en vrac:
+cAA--------------------
+cAA 1/ le call phytrac se fait avec nqmax-2 donc nous avons bien 
+cAA les vrais traceurs (nbtr) dans phytrac (pas la vapeur ni eau liquide)
+cAA 2/ Le choix du radon et du pb se fait juste avec un data 
+cAA    (peu propre). Peut-etre pourrait-on prevoir dans l'avenir 
+cAA    une variable "type de traceur" 
+c======================================================================
+#include "YOMCST.h"
+#include "dimensions.h"
+#include "indicesol.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "paramet.h"
+#include "control.h"
+#include "advtrac.h"
+#include "thermcell.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon  ! nombre de points horizontaux
+      integer nlev  ! nombre de couches verticales
+      integer nqmax ! nombre de traceurs auxquels on applique la physique
+      integer nstep  ! appel physique
+      integer julien !jour julien
+      integer itop_con(nlon)
+      integer ibas_con(nlon)
+      real gmtime
+      real pdtphys  ! pas d'integration pour la physique (seconde)
+      real t_seri(nlon,nlev) ! temperature
+      real tr_seri(nlon,nlev,nbtr) ! traceur  
+      real u(klon,klev)
+      real v(klon,klev)
+      real sh(nlon,nlev)     ! humidite specifique
+      real rh(nlon,nlev)     ! humidite relative
+      real cldliq(nlon,nlev) ! eau liquide nuageuse
+      real cldfra(nlon,nlev) ! fraction nuageuse (tous les nuages)
+      real diafra(nlon,nlev) ! fraction nuageuse (convection ou stratus artificiels)
+      real rneb(nlon,nlev)   ! fraction nuageuse (grande echelle)
+      real albsol(nlon)  ! albedo surface
+      real paprs(nlon,nlev+1)  ! pression pour chaque inter-couche (en Pa)
+      real ps(nlon)  ! pression surface
+      real pplay(nlon,nlev)  ! pression pour le mileu de chaque couche (en Pa)
+      real pphi(nlon,klev) ! geopotentiel
+      real pphis(klon)
+      REAL presnivs(klev)
+      logical debutphy       ! le flag de l'initialisation de la physique
+      logical lafin          ! le flag de la fin de la physique
+c Olivia      
+      integer nsplit
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--lessivage convection
+      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--lessivage large-scale
+      LOGICAL aerosol_couple
+
+      REAL flxmass_w(klon,klev)
+      CHARACTER(len=8) :: solsym(nqmax)
+      integer la
+      REAL              ::    tau_inca(klon,klev,9,2)
+      REAL              ::    piz_inca(klon,klev,9,2)
+      REAL              ::    cg_inca(klon,klev,9,2)
+      character*4       ::    rfname(9) 
+      REAL              ::    ccm(klon,klev,2) 
+c
+c   convection:
+c   -----------
+c
+      REAL pmfu(nlon,nlev)  ! flux de masse dans le panache montant
+      REAL pmfd(nlon,nlev)  ! flux de masse dans le panache descendant
+      REAL pen_u(nlon,nlev) ! flux entraine dans le panache montant
+
+c
+c   thermiques:
+c   -----------
+c
+      real fm_therm(klon,klev+1),entr_therm(klon,klev)
+	real fm_therm1(klon,klev)
+c
+      REAL pde_u(nlon,nlev) ! flux detraine dans le panache montant
+      REAL pen_d(nlon,nlev) ! flux entraine dans le panache descendant
+      REAL pde_d(nlon,nlev) ! flux detraine dans le panache descendant
+c KE
+      real da(nlon,nlev),phi(nlon,nlev,nlev),mp(nlon,nlev)
+      REAL upwd(nlon,nlev)      ! saturated updraft mass flux
+      REAL dnwd(nlon,nlev)      ! saturated downdraft mass flux
+
+c
+c   Couche limite:
+c   --------------
+c
+      REAL coefh(nlon,nlev) ! coeff melange CL
+      REAL yu1(nlon)        ! vents au premier niveau
+      REAL yv1(nlon)        ! vents au premier niveau
+      REAL xlat(nlon)       ! latitudes pour chaque point 
+      REAL xlon(nlon)       ! longitudes pour chaque point 
+
+c
+c   Lessivage:
+c   ----------
+c
+c pour le ON-LINE
+c
+      REAL frac_impa(nlon,nlev)  ! fraction d'aerosols impactes
+      REAL frac_nucl(nlon,nlev)  ! fraction d'aerosols nuclees
+c
+cAA
+cAA Arguments necessaires pour les sources et puits de traceur:
+cAA ----------------
+cAA
+      real ftsol(nlon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(nlon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c abder
+      real pftsol1(nlon),pftsol2(nlon),pftsol3(nlon),pftsol4(nlon)
+      real ppsrf1(nlon),ppsrf2(nlon),ppsrf3(nlon),ppsrf4(nlon)
+c fin
+cAA ----------------------------
+cAA  VARIABLES LOCALES TRACEURS
+cAA ----------------------------
+cAA
+cAA Sources et puits des traceurs:
+cAA ------------------------------
+cAA
+cAA Pour l'instant seuls les cas du rn et du pb ont ete envisages.
+
+      REAL source(klon,nqmax)       ! a voir lorsque le flux est prescrit 
+cAA 
+cAA Pour la source de radon et son reservoir de sol
+cAA ................................................
+ 
+      REAL,save,allocatable :: trs(:,:)    ! Conc. radon ds le sol
+c$OMP THREADPRIVATE(trs)
+cym      SAVE trs
+      REAL :: trs_tmp(klon_glo)
+      
+      REAL,save,allocatable :: masktr(:,:) ! Masque reservoir de sol traceur
+c                            Masque de l'echange avec la surface
+c                           (1 = reservoir) ou (possible => 1 )
+c$OMP THREADPRIVATE(masktr)
+cym      SAVE masktr
+      REAL,save,allocatable :: fshtr(:,:)  ! Flux surfacique dans le reservoir de sol
+c$OMP THREADPRIVATE(fshtr)
+cym      SAVE fshtr
+      REAL,save,allocatable :: hsoltr(:)      ! Epaisseur equivalente du reservoir de sol
+c$OMP THREADPRIVATE(hsoltr)
+cym      SAVE hsoltr
+      REAL,save,allocatable :: tautr(:)       ! Constante de decroissance radioactive
+c$OMP THREADPRIVATE(tautr)
+cym      SAVE tautr
+      REAL,save,allocatable :: vdeptr(:)      ! Vitesse de depot sec dans la couche Brownienne
+c$OMP THREADPRIVATE(vdeptr)
+cym      SAVE vdeptr
+      REAL,save,allocatable :: scavtr(:)      ! Coefficient de lessivage
+c$OMP THREADPRIVATE(scavtr)
+cym      SAVE scavtr
+cAA
+      CHARACTER*2 itn
+C maf ioipsl
+      CHARACTER*2 str2
+      INTEGER nhori, nvert
+      REAL zsto, zout, zjulian
+      INTEGER, SAVE :: nid_tra
+c$OMP THREADPRIVATE(nid_tra)
+      INTEGER, SAVE :: nid_tra2,nid_tra3
+c$OMP THREADPRIVATE(nid_tra2,nid_tra3)
+      INTEGER ndex(1)
+      INTEGER ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev)
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+c
+      integer itau_w   ! pas de temps ecriture = nstep + itau_phy
+c
+      logical ok_sync
+      parameter (ok_sync = .true.)
+C
+C nature du traceur
+c
+      logical,save,allocatable :: aerosol(:)  ! Nature du traceur
+c                            ! aerosol(it) = true  => aerosol 
+c                            ! aerosol(it) = false => gaz 
+c                            ! nat_trac(it) = 1. aerosol
+      logical,save,allocatable :: clsol(:)    ! clsol(it) = true => CL sol calculee
+      logical,save,allocatable :: radio(:)    ! radio(it)=true => decroisssance radioactive
+c$OMP THREADPRIVATE(aerosol,clsol,radio)  
+cym      save aerosol,clsol,radio
+C
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+c--modif convection tiedtke
+      INTEGER i, k, it
+      INTEGER iq, iiq
+      REAL delp(klon,klev)
+c--end modif
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c Variables locales pour effectuer les appels en serie
+c----------------------------------------------------
+c
+      REAL d_tr(klon,klev), d_trs(klon) ! tendances de traceurs 
+      REAL d_tr_cl(klon,klev,nbtr) ! tendance de traceurs  couche limite
+      REAL d_tr_cv(klon,klev,nbtr) ! tendance de traceurs  conv pour chq traceur
+      REAL d_tr_th(klon,klev,nbtr) ! la tendance des thermiques
+      REAL d_tr_dec(klon,klev,nbtr) ! la tendance de la decroissance 
+c                                   ! radioactive du rn - > pb 
+      REAL d_tr_lessi_impa(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par impaction
+      REAL d_tr_lessi_nucl(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par nucleation 
+      REAL fluxrn(klon,klev) 
+      REAL fluxpb(klon,klev) 
+      REAL pbimpa(klon,klev) 
+      REAL pbnucl(klon,klev) 
+      REAL rn(klon,klev) 
+      REAL pb(klon,klev) 
+      REAL flestottr(klon,klev,nbtr) ! flux de lessivage 
+c                                    ! dans chaque couche 
+      real zmasse(klon,klev)
+      real ztra_th(klon,klev)
+
+C
+      character*20 modname
+      character*80 abort_message
+c
+c   Controles
+c-------------
+      logical first,couchelimite,convection,lessivage,sorties,
+     s        rnpb,inirnpb
+      save first,couchelimite,convection,lessivage,
+     s        sorties,inirnpb
+c$OMP THREADPRIVATE(first,couchelimite,convection,lessivage,
+c$OMP+              sorties,inirnpb)
+c      data first,couchelimite,convection,lessivage,sorties
+c     s     /.true.,.true.,.false.,.true.,.true./
+c Olivia
+       data first,couchelimite,convection,lessivage,
+     s      sorties
+     s     /.true.,.true.,.true.,.true.,.true./
+
+! Variables needed for configuration with INCA
+      INTEGER           :: lastgas
+      INTEGER           :: ncsec
+
+      REAL, PARAMETER   :: dry_mass = 28.966
+      REAL, POINTER     :: hbuf(:)
+      REAL, ALLOCATABLE :: obuf(:)
+      REAL              :: calday
+      REAL              :: pdel(klon,klev)
+c
+c======================================================================
+
+         modname='phytrac'
+
+         ps(:)=paprs(:,1)
+
+         if (debutphy) then
+           allocate( trs(klon,nbtr) )
+	   allocate( masktr(klon,nbtr)) 
+           allocate( fshtr(klon,nbtr) )
+           allocate( hsoltr(nbtr))
+           allocate( tautr(nbtr))
+           allocate( vdeptr(nbtr))
+           allocate( scavtr(nbtr))
+           allocate( aerosol(nbtr))
+           allocate( clsol(nbtr))
+           allocate( radio(nbtr))
+
+
+! FH 2008/05/09 correction de la frequence d'ecriture des traceurs
+!         ecrit_tra = FLOAT(NINT(86400./pdtphys *ecritphy)) 
+          print*,'dans phytrac ',pdtphys,ecrit_tra
+
+         if(nbtr.lt.nqmax) then
+c           print*,'NQMAX=',nqmax
+c           print*,'NBTR=',nbtr
+           abort_message='See above'
+           call abort_gcm(modname,abort_message,1)
+         endif
+
+         inirnpb=rnpb
+         PRINT*, 'La frequence de sortie traceurs est  ', ecrit_tra
+C         
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+#include "ini_histrac.h"
+#endif
+
+c======================================================================
+c   Initialisation de certaines variables pour le Rn et le Pb 
+c======================================================================
+
+c Initialisation du traceur dans le sol (couche limite radonique)
+c
+c        print*,'valeur de debut dans phytrac :',debutphy
+         trs(:,:) = 0.
+c$OMP MASTER         
+       if (is_mpi_root) then
+         trs_tmp(:)=0.
+	 open (99,file='starttrac',status='old',
+     .         err=999,form='formatted')
+         read(99,*) (trs_tmp(i),i=1,klon_glo)
+999      close(99)
+       endif
+c$OMP END MASTER
+       call Scatter(trs_tmp,trs(:,1))
+
+c         print*, 'apres starttrac'
+
+c Initialisation de la fraction d'aerosols lessivee
+c
+         d_tr_lessi_impa(:,:,:) = 0.
+         d_tr_lessi_nucl(:,:,:) = 0. 
+c
+c Initialisation de la nature des traceurs
+c
+         DO it = 1, nqmax
+            aerosol(it) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
+            radio(it) = .FALSE.    ! Par defaut pas de passage par radiornpb
+            clsol(it) = .FALSE.  ! Par defaut couche limite avec flux prescrit
+         ENDDO
+c
+      ENDIF  ! fin debutphy 
+c Initialisation du traceur dans le sol (couche limite radonique)
+      if(inirnpb) THEN
+c
+         radio(1)= .true.
+         radio(2)= .true.
+         clsol(1)= .true.
+         clsol(2)= .true.
+         aerosol(2) = .TRUE. ! le Pb est un aerosol 
+c
+         call initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+         inirnpb=.false.
+      endif
+
+
+      IF (config_inca == 'none') THEN
+       DO i=1,nlon
+          pftsol1(i) = ftsol(i,1)
+          pftsol2(i) = ftsol(i,2)
+          pftsol3(i) = ftsol(i,3)
+          pftsol4(i) = ftsol(i,4)
+
+          ppsrf1(i) = pctsrf(i,1)
+          ppsrf2(i) = pctsrf(i,2)
+          ppsrf3(i) = pctsrf(i,3)
+          ppsrf4(i) = pctsrf(i,4)
+
+       ENDDO
+
+      ELSE ! config_inca /=none
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+
+!======================================================================
+!     Chimie
+!======================================================================
+
+        calday = FLOAT(julien) + gmtime
+        ncsec  = NINT (86400.*gmtime)
+
+        DO k = 1, nlev
+        pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+        END DO
+
+        IF (config_inca == 'aero') THEN
+           CALL aerosolmain (aerosol_couple,
+     $                 tr_seri,
+     $                 pdtphys,
+     $                 pplay,
+     $                 pdel,
+     $                 prfl,
+     $                 pmflxr,
+     $                 psfl,
+     $                 pmflxs,
+     $                 pmfu,
+     $                 itop_con,
+     $                 ibas_con,
+     $                 pphi,
+     $                 airephy, ! paire,
+     $                 nstep,
+     $                 rneb,         ! for chimiaq
+     $                 t_seri,       ! for chimiaq
+     $                 rh,
+     $                 tau_inca,
+     $                 piz_inca,
+     $                 cg_inca,
+     $                 rfname,
+     $                 ccm,
+     $                 lafin)
+        END IF
+
+        CALL chemmain (tr_seri,    !mmr
+     $                 nstep,      !nstep
+     $                 calday,     !calday
+     $                 julien,     !ncdate
+     $                 ncsec,      !ncsec
+     $                 1,          !lat
+     $                 pdtphys,    !delt
+     $                 paprs(1,1), !ps
+     $                 pplay,      !pmid
+     $                 pdel,       !pdel
+     $                 airephy,
+     $                 pctsrf(1,1),!oro
+     $                 ftsol,      !tsurf
+     $                 albsol,     !albs
+     $                 pphi,       !zma
+     $                 pphis,      !phis
+     $                 cldfra,     !cldfr
+     $                 rneb,       !cldfr_st
+     $                 diafra,     !cldfr_cv
+     $                 itop_con,   !cldtop
+     $                 ibas_con,   !cldbot
+     $                 cldliq,     !cwat
+     $                 prfl,       !flxrst
+     $                 pmflxr,     !flxrcv
+     $                 psfl,       !flxsst
+     $                 pmflxs,     !flxscv
+     $                 pmfu,       !flxupd
+     $                 flxmass_w,  !flxmass_w
+     $                 t_seri,     !tfld
+     $                 sh,         !sh
+     $                 rh,         !rh
+     $                 .false.,    !wrhstts
+     $                 hbuf,       !hbuf
+     $                 obuf,       !obuf
+     $                 iip1,       !nx
+     $                 jjp1,       !ny
+     $                 source,
+     $                 solsym)
+
+
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+      END IF ! config_inca
+c======================================================================
+c   Calcul de l'effet de la convection
+c======================================================================
+c     print*,'Avant convection'
+       do it=1,nqmax
+          WRITE(itn,'(i2)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+       enddo
+
+      if (convection) then
+
+c      print*,'Pas de temps dans phytrac : ',pdtphys
+      DO it=1, nqmax
+
+      IF ( config_inca/='none' .AND. conv_flg(it) == 0 ) CYCLE
+
+      if (iflag_con.lt.2) then
+       d_tr_cv=0.
+      else if (iflag_con.eq.2) then
+c tiedke
+      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .            pplay, paprs, tr_seri(1,1,it), d_tr_cv(1,1,it))
+      else
+c KE
+      call cvltr(pdtphys, da, phi, mp, paprs,pplay, tr_seri(1,1,it),
+     .           upwd,dnwd,d_tr_cv(1,1,it))
+      endif
+
+       DO k = 1, nlev
+       DO i = 1, klon
+         tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it)
+       ENDDO
+       ENDDO
+
+       IF (config_inca == 'none') THEN
+        CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '//itn)
+       ELSE
+        CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '
+     .         //solsym(it))
+       END IF   
+      
+      ENDDO
+
+      endif ! convection
+c        print*,'Apres convection'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+c      enddo
+
+
+c======================================================================
+c   Calcul de l'effet des thermiques
+c======================================================================
+
+      do k=1,klev
+         do i=1,klon
+            zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
+         enddo
+      enddo
+
+c      print*,'masse dans ph ',zmasse
+      do it=1,nqmax
+         do k=1,klev
+            do i=1,klon
+               d_tr_th(i,k,it)=0.
+               tr_seri(i,k,it)=max(tr_seri(i,k,it),0.)
+               tr_seri(i,k,it)=min(tr_seri(i,k,it),1.e10)
+            enddo
+         enddo
+      enddo
+
+      if (iflag_thermals.gt.0) then
+c        print*,'calcul de leffet des thermiques'
+        nsplit=10
+        DO it=1, nqmax
+c        WRITE(itn,'(i1)') it
+c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'conv it='//itn)
+c	     print*,'avant dqthermiquesretro'
+c             call dump2d(iim,jjm-1,tr_seri(2,1,1),'TR_SERI      ')
+
+         do isplit=1,nsplit
+c  Abderr 25 11 02
+C Thermiques 
+c	print*,'Avant dans phytrac'
+            call dqthermcell(klon,klev,pdtphys/nsplit
+     .       ,fm_therm,entr_therm,zmasse
+     .       ,tr_seri(1:klon,1:klev,it),d_tr,ztra_th)
+
+            do k=1,klev
+               do i=1,klon
+                  d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit
+                  d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k)
+                  tr_seri(i,k,it)=max(tr_seri(i,k,it)+d_tr(i,k),0.)
+               enddo
+            enddo
+          enddo ! nsplit
+c          print*,'apres thermiques'
+c             call dump2d(iim,jjm-1,d_tr_th(1,1,1),'d_tr_th      ')
+c            do k=1,klev
+c	print*,'d_tr_th(',k,')=',tr_seri(280,k,1)
+c	   enddo
+
+c        WRITE(itn,'(i1)') it
+c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'therm it='//itn)
+       ENDDO ! it
+       endif ! Thermiques
+c       print*,'ATTENTION: sdans thermniques'
+      
+c======================================================================
+c   Calcul de l'effet de la couche limite
+c======================================================================
+c	print *,'Avant couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
+      if (couchelimite) then
+
+      DO k = 1, nlev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k)-paprs(i,k+1)
+      ENDDO
+      ENDDO
+
+C maf modif pour tenir compte du cas rnpb + traceur
+      DO it=1, nqmax
+
+      IF ( config_inca/='none' .AND. pbl_flg(it) == 0 ) CYCLE
+
+c     print *,'it',it,clsol(it)
+      if (clsol(it)) then  ! couche limite avec quantite dans le sol calculee
+          CALL cltracrn(it, pdtphys, yu1, yv1,
+     e                    coefh,t_seri,ftsol,pctsrf,
+     e                    tr_seri(1,1,it),trs(1,it),
+     e                    paprs, pplay, delp,
+     e                    masktr(1,it),fshtr(1,it),hsoltr(it),
+     e                    tautr(it),vdeptr(it),
+     e                    xlat,
+     s                    d_tr_cl(1,1,it),d_trs)
+          DO k = 1, nlev
+            DO i = 1, klon
+              tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+            ENDDO
+          ENDDO
+c
+c Traceur ds sol
+c
+          DO i = 1, klon
+            trs(i,it) = trs(i,it) + d_trs(i)
+          END DO
+C
+C maf provisoire suppression des prints
+C         WRITE(itn,'(i1)') it
+C         CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracrn it='//itn)
+      else ! couche limite avec flux prescrit
+#ifndef INCA
+
+Cmaf provisoire source / traceur a creer
+        DO i=1, klon
+          source(i,it) = 0.0 ! pas de source, pour l'instant
+        ENDDO
+C
+#endif
+          CALL cltrac(pdtphys, coefh,t_seri,
+     s               tr_seri(1,1,it), source(:,it),
+     e               paprs, pplay, delp,
+     s               d_tr_cl(1,1,it))
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+               ENDDO
+            ENDDO
+Cmaf          WRITE(itn,'(i1)') it
+cmaf          CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracn it='//itn)
+      endif
+      ENDDO
+c
+      endif ! couche limite
+
+c      print*,'Apres couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
+c======================================================================
+c   Calcul de l'effet du puits radioactif
+c======================================================================
+
+C MAF il faudrait faire une modification pour passer dans radiornpb 
+c si radio=true mais pour l'instant radiornpb propre au cas rnpb
+      if(rnpb) then
+c       print *, 'decroissance radiactive activee'
+        call radiornpb (tr_seri,pdtphys,tautr,d_tr_dec)
+C
+        DO it=1,nqmax
+            if(radio(it)) then
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
+               ENDDO
+            ENDDO
+            WRITE(itn,'(i1)') it
+            CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'puits rn it='//itn)
+            endif
+        ENDDO
+c
+      endif ! rnpb decroissance  radioactive
+C
+c======================================================================
+c   Calcul de l'effet de la precipitation
+c======================================================================
+
+c      print*,'LESSIVAGE =',lessivage
+      IF (lessivage) THEN
+
+c     print*,'avant lessivage'
+
+          d_tr_lessi_nucl(:,:,:) = 0. 
+          d_tr_lessi_impa(:,:,:) = 0. 
+          flestottr(:,:,:) = 0. 
+c
+c tendance des aerosols nuclees et impactes 
+c
+       DO it = 1, nqmax
+         IF (aerosol(it)) THEN
+           DO k = 1, nlev
+              DO i = 1, klon
+               d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +
+     s                  ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+               d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +
+     s                  ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c
+c Mises a jour des traceurs + calcul des flux de lessivage 
+c Mise a jour due a l'impaction et a la nucleation
+c
+c      call dump2d(iim,jjm-1,frac_impa(2:klon-1,10),'FRACIMPA')
+c      call dump2d(iim,jjm-1,frac_nucl(2:klon-1,10),'FRACNUCL')
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3')
+       DO it = 1, nqmax
+c         print*,'IT=',it,aerosol(it)
+         IF (aerosol(it)) THEN
+c           print*,'IT=',it,' On lessive'
+           DO k = 1, nlev
+              DO i = 1, klon
+               tr_seri(i,k,it)=tr_seri(i,k,it)
+     s         *frac_impa(i,k)*frac_nucl(i,k)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3B')
+c
+c Flux lessivage total 
+c
+      DO it = 1, nqmax
+           DO k = 1, nlev
+            DO i = 1, klon
+               flestottr(i,k,it) = flestottr(i,k,it) -
+     s                   ( d_tr_lessi_nucl(i,k,it)   +
+     s                     d_tr_lessi_impa(i,k,it) ) *
+     s                   ( paprs(i,k)-paprs(i,k+1) ) / 
+     s                   (RG * pdtphys)
+            ENDDO
+           ENDDO
+c
+Cmaf        WRITE(itn,'(i1)') it
+Cmaf    CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'tr(lessi) it='//itn)
+      ENDDO
+c
+c     print*,'apres lessivage'
+      ENDIF
+Cc
+      DO k = 1, nlev
+         DO i = 1, klon
+            fluxrn(i,k) = flestottr(i,k,1)
+            fluxpb(i,k) = flestottr(i,k,2)
+            rn(i,k) = tr_seri(i,k,1)
+            pb(i,k) = tr_seri(i,k,2)
+            pbnucl(i,k)=d_tr_lessi_nucl(i,k,2)
+            pbimpa(i,k)=d_tr_lessi_impa(i,k,2)
+         ENDDO
+      ENDDO
+
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+#include "write_histrac.h"
+#endif
+
+c=============================================================
+
+      if (lafin) then
+         print*, 'c est la fin de la physique'
+	 call Gather(trs(:,1),trs_tmp)
+c$OMP MASTER	 
+	 if (is_mpi_root) then
+         
+	   open (99,file='restarttrac',  form='formatted')
+           do i=1,klon_glo
+               write(99,*) trs_tmp(i)
+           enddo
+           PRINT*, 'Ecriture du fichier restarttrac'
+           close(99)
+	 endif
+c$OMP END MASTER
+      else
+c         print*, 'physique pas fini'
+      endif
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/plevel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/plevel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/plevel.F	(revision 984)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cy#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cym      INTEGER lt(klon), lb(klon)
+cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb
+c$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+c$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+c$OMP THREADPRIVATE(first)
+      INTEGER i, k
+c
+      if (first) then
+        allocate(lt(klon),lb(klon),aist(klon),aisb(klon))
+	first=.false.
+      endif
+      
+c=====================================================================
+      if (lnew) then
+c   on r�nitialise les r�ndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, klon
+         IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, klon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+            IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, klon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Fr��ic Hourdin (3/01/02)
+
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,klon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, klon
+         if (pgcm(i,1).LT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/print_debug_phys.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/print_debug_phys.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/print_debug_phys.F90	(revision 984)
@@ -0,0 +1,20 @@
+SUBROUTINE print_debug_phys (i,debug_lev,text)
+
+use dimphy
+use phys_local_var_mod
+use phys_state_var_mod
+IMPLICIT NONE
+integer i,debug_lev
+CHARACTER*(*) text
+
+
+integer k
+
+print*,'PLANTAGE POUR LE POINT i=',i,text
+print*,'l    u, v, T, q, ql'
+DO k = 1, klev
+   write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,rlon(i),rlat(i),u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k)
+ENDDO
+
+RETURN
+END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/printflag.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/printflag.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/printflag.F	(revision 984)
@@ -0,0 +1,183 @@
+!
+! $Header$
+!
+       SUBROUTINE  printflag( tabcntr0, radpas, 
+     ,                        ok_journe,ok_instan,ok_region        )
+c
+
+c
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+       REAL tabcntr0( 100 )
+       LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
+       LOGICAL ok_orolf0,ok_limitvr0
+       LOGICAL ok_journe,ok_instan,ok_region
+       INTEGER radpas , radpas0
+c
+#include "clesphys.h"
+c
+c
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT *,' ********   Choix  des principales  cles de la physique 
+     ,   *********'
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+       PRINT 10, cycle_diurne,  soil_model  
+       PRINT 100
+
+       IF   (    iflag_con.EQ. 1 )   THEN
+           PRINT *,' *****           Shema  convection   LMD            
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 2 )   THEN
+           PRINT *,' *****           Shema  convection  Tiedtke  
+     ,          ******'
+       ELSE IF ( iflag_con.GE. 3 )   THEN
+           PRINT *,' *****           Shema  convection    Emanuel      
+     ,          ******'
+       ENDIF
+       PRINT 100
+
+       PRINT 11, new_oliq, ok_orodr, ok_orolf   
+       PRINT 100
+
+       PRINT 7,  ok_limitvrai   
+       PRINT 100
+
+       PRINT 12, nbapp_rad
+       PRINT 100
+
+       PRINT 8, radpas
+       PRINT 100
+
+       PRINT 4,ok_journe,ok_instan,ok_region
+       PRINT 100
+       PRINT 100
+c
+c
+        cycle_diurn0  = .FALSE.
+        soil_model0   = .FALSE.
+        new_oliq0     = .FALSE.
+        ok_orodr0     = .FALSE.
+        ok_orolf0     = .FALSE.
+        ok_limitvr0   = .FALSE.
+
+        IF( tabcntr0( 7 ).EQ. 1. )   cycle_diurn0 = .TRUE.
+        IF( tabcntr0( 8 ).EQ. 1. )    soil_model0 = .TRUE.
+        IF( tabcntr0( 9 ).EQ. 1. )      new_oliq0 = .TRUE.
+        IF( tabcntr0(10 ).EQ. 1. )      ok_orodr0 = .TRUE.
+        IF( tabcntr0(11 ).EQ. 1. )      ok_orolf0 = .TRUE.
+        IF( tabcntr0(12 ).EQ. 1. )    ok_limitvr0 = .TRUE.
+
+        PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+     ,$$$$$$$$$$$$$'
+        PRINT 100
+c
+       IF( INT( tabcntr0( 5 ) ) .NE. iflag_con  )   THEN
+        PRINT 20, INT(tabcntr0(5)), iflag_con
+        PRINT 100
+       ENDIF
+
+       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
+        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
+        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+        PRINT 100
+        PRINT 22, radpas0, radpas
+        PRINT 100
+       ENDIF
+
+       IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND.
+     ,        cycle_diurne )     THEN
+        PRINT 13, cycle_diurn0, cycle_diurne
+        PRINT 100
+       ENDIF
+
+       IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND.
+     ,        soil_model )     THEN
+        PRINT 14, soil_model0, soil_model
+        PRINT 100
+       ENDIF
+
+       IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND.
+     ,        new_oliq )     THEN
+        PRINT 16, new_oliq0, new_oliq
+        PRINT 100
+       ENDIF
+
+       IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND.
+     ,        ok_orodr )     THEN
+        PRINT 15, ok_orodr0, ok_orodr
+        PRINT 100
+       ENDIF
+
+       IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND.
+     ,        ok_orolf )     THEN
+        PRINT 17, ok_orolf0, ok_orolf
+        PRINT 100
+       ENDIF
+
+       IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0.
+     ,     AND.ok_limitvrai )     THEN
+        PRINT 18, ok_limitvr0, ok_limitvrai
+        PRINT 100
+       ENDIF
+
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+
+ 4    FORMAT(2x,5(1H*),'  ok_journe= ',l3,3x,',ok_instan = ',
+     , l3,3x,',ok_region = ',l3,3x,5(1H*) )
+
+ 7     FORMAT(2x,5(1H*),15x,'      ok_limitvrai   = ',l3,16x,5(1h*) )
+
+ 8     FORMAT(2x,'*****             radpas    =                      ' ,
+     , i4,6x,' *****')
+
+ 10    FORMAT(2x,5(1H*),'    Cycle_diurne = ',l3,4x,', Soil_model = ',
+     , l3,12x,6(1H*) )
+
+
+ 11    FORMAT(2x,5(1H*),'  new_oliq = ',l3,3x,', Ok_orodr = ',
+     , l3,3x,', Ok_orolf = ',l3,3x,5(1H*) )
+
+
+ 12    FORMAT(2x,'*****  Nb d appels /jour des routines de rayonn. = ' ,
+     , i4,6x,' *****')
+
+ 13    FORMAT(2x,'$$$$$$$$   Attention !!  cycle_diurne  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 14    FORMAT(2x,'$$$$$$$$   Attention !!    soil_model  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 15    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orodr  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 16    FORMAT(2x,'$$$$$$$$   Attention !!      new_oliq  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 17    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orolf  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 18    FORMAT(2x,'$$$$$$$$   Attention !!  ok_limitvrai  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 20    FORMAT(/2x,'$$$$$$$$   Attention !!    iflag_con  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 21    FORMAT(2x,'$$$$$$$$   Attention !!     nbapp_rad  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 22    FORMAT(2x,'$$$$$$$$   Attention !!        radpas  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 100   FORMAT(/)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.160.98.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.160.98.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.160.98.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=78,kflev=klev) ! 78*199
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.192.143.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.192.143.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.192.143.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+       INTEGER kdlon, kflev
+      PARAMETER (kdlon=10,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.32.24.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.32.24.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.32.24.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.48.32.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.48.32.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.48.32.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.72.46.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.72.46.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.72.46.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=1621,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.96.72.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.96.72.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.96.72.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=487,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.defaut.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.defaut.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.defaut.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddim.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/raddimlw.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/raddimlw.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/raddimlw.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+      INTEGER NUA
+      PARAMETER (NUA=24)
+      INTEGER NTRA
+      PARAMETER (NTRA=15)
+      INTEGER Ninter
+      PARAMETER (Ninter=6)
+      INTEGER NG1, NG1P1
+      PARAMETER (NG1=2, NG1P1=NG1+1)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/radepsi.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/radepsi.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/radepsi.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      REAL*8 ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW
+      REAL*8 ZEPSEC, ZEPSCR
+      PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines)
+      PARAMETER (ZEPSC  = 1.E-20)
+      PARAMETER (ZEPSCO = 1.E-10)
+      PARAMETER (ZEPSCQ = 1.E-10)
+      PARAMETER (ZEPSCT = 1.E-20)
+      PARAMETER (ZEPSCW = 1.E-20)
+      PARAMETER (ZEPSEC = 1.0E-12)
+      PARAMETER (ZEPSCR = 1.0E-10)
+c
+      REAL*8 REPSCT
+      PARAMETER (REPSCT=1.0E-10)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/radiornpb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/radiornpb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/radiornpb.F	(revision 984)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE radiornpb(tr,dtime,tautr,d_tr) 
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: Decroissance radioactive d'un traceur dans l'atmosphere
+CG240694 : Pour un traceur, le radon
+CG161294 : Plus un 2eme traceur, le 210Pb. Le radon decroit en plomb.
+c======================================================================
+c Arguments:
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c======================================================================
+C
+      INTEGER i , k , it
+      REAL tr(klon,klev,nbtr) , d_tr(klon,klev,nbtr)
+      REAL dtime
+      REAL tautr(nbtr)
+C
+c      WRITE(*,'(''PASSAGE radiornpb ... '',$)')
+C Attention, pour un pas de temps beaucoup plus petit que la decroissance!!!
+
+      DO it = 1,2
+           IF ( tautr(it) .GT. 0. ) THEN
+          	DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
+                END DO
+                END DO
+           ELSE
+                DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = 0.
+                END DO
+                END DO
+           END IF
+      END DO
+C
+CG161294 : Cas particulier radon 1 => plomb 2
+c
+      DO k = 1,klev
+        DO i = 1,klon
+          d_tr(i,k,2) = d_tr(i,k,2) - d_tr(i,k,1)
+        ENDDO
+      ENDDO
+c
+c      WRITE(*,*) ' radiornpb OK'
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/radlwsw.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/radlwsw.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/radlwsw.F	(revision 984)
@@ -0,0 +1,6573 @@
+!
+! $Header$
+!
+      SUBROUTINE radlwsw(dist, rmu0, fract, 
+     .                  paprs, pplay,tsol,alb1, alb2, t,q,wo,
+     .                  cldfra, cldemi, cldtaupd,
+     .                  heat,heat0,cool,cool0,radsol,albpla,
+     .                  topsw,toplw,solsw,sollw,
+     .                  sollwdown,
+     .                  topsw0,toplw0,solsw0,sollw0,
+     .                  lwdn0, lwdn, lwup0, lwup,
+     .                  swdn0, swdn, swup0, swup,
+     .                  ok_ade, ok_aie,
+     .                  tau_ae, piz_ae, cg_ae,
+     .                  topswad, solswad,
+     .                  cldtaupi, topswai, solswai)
+c      
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
+c Objet: interface entre le modele et les rayonnements
+c Arguments:
+c dist-----input-R- distance astronomique terre-soleil
+c rmu0-----input-R- cosinus de l'angle zenithal
+c fract----input-R- duree d'ensoleillement normalisee
+c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
+c solaire--input-R- constante solaire (W/m**2)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c tsol-----input-R- temperature du sol (en K)
+c alb1-----input-R- albedo du sol(entre 0 et 1) dans l'interval visible
+c alb2-----input-R- albedo du sol(entre 0 et 1) dans l'interval proche infra-rouge
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (en kg/kg)
+c wo-------input-R- contenu en ozone (en kg/kg) correction MPL 100505
+c cldfra---input-R- fraction nuageuse (entre 0 et 1)
+c cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value)
+c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
+c ok_ade---input-L- apply the Aerosol Direct Effect or not?
+c ok_aie---input-L- apply the Aerosol Indirect Effect or not?
+c tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F)
+c cldtaupi-input-R- epaisseur optique des nuages dans le visible
+c                   calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller
+c                   droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd
+c                   it is needed for the diagnostics of the aerosol indirect radiative forcing      
+c
+c heat-----output-R- echauffement atmospherique (visible) (K/jour)
+c cool-----output-R- refroidissement dans l'IR (K/jour)
+c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
+c albpla---output-R- albedo planetaire (entre 0 et 1)
+c topsw----output-R- flux solaire net au sommet de l'atm.
+c toplw----output-R- ray. IR montant au sommet de l'atmosphere
+c solsw----output-R- flux solaire net a la surface
+c sollw----output-R- ray. IR montant a la surface
+c solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir)
+c topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir)
+c solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind)
+c topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind)
+c
+c ATTENTION: swai and swad have to be interpreted in the following manner:
+c ---------
+c ok_ade=F & ok_aie=F -both are zero
+c ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad
+c                        indirect is zero
+c ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+c                        direct is zero
+c ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+c                        aerosol direct forcing is F_{AD} = topswai-topswad
+c
+      
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOETHF.h"
+c
+      real rmu0(klon), fract(klon), dist
+cIM   real co2_ppm
+cIM   real solaire
+#include "clesphys.h" 
+c
+      real paprs(klon,klev+1), pplay(klon,klev)
+      real alb1(klon), alb2(klon), tsol(klon)
+      real t(klon,klev), q(klon,klev), wo(klon,klev)
+      real cldfra(klon,klev), cldemi(klon,klev), cldtaupd(klon,klev)
+      real heat(klon,klev), cool(klon,klev)
+      real heat0(klon,klev), cool0(klon,klev)
+      real radsol(klon), topsw(klon), toplw(klon)
+      real solsw(klon), sollw(klon), albpla(klon)
+      real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
+      real sollwdown(klon)
+cIM output 3D 
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+c
+      REAL*8 ZFLUP(KDLON,KFLEV+1)
+      REAL*8 ZFLDN(KDLON,KFLEV+1)
+      REAL*8 ZFLUP0(KDLON,KFLEV+1)
+      REAL*8 ZFLDN0(KDLON,KFLEV+1)
+c
+      REAL*8 zx_alpha1, zx_alpha2
+c
+#include "YOMCST.h"
+c
+      INTEGER k, kk, i, j, iof, nb_gr
+      EXTERNAL lw, sw
+c
+cIM ctes ds clesphys.h  REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
+      REAL*8 PSCT
+c
+      REAL*8 PALBD(kdlon,2), PALBP(kdlon,2)
+      REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
+      REAL*8 PPSOL(kdlon), PDP(kdlon,klev)
+      REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
+      REAL*8 PTAVE(kdlon,kflev)
+      REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev)
+      REAL*8 PAER(kdlon,kflev,5)
+      REAL*8 PCLDLD(kdlon,kflev)
+      REAL*8 PCLDLU(kdlon,kflev)
+      REAL*8 PCLDSW(kdlon,kflev)
+      REAL*8 PTAU(kdlon,2,kflev)
+      REAL*8 POMEGA(kdlon,2,kflev)
+      REAL*8 PCG(kdlon,2,kflev)
+c
+      REAL*8 zfract(kdlon), zrmu0(kdlon), zdist
+c
+      REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev)
+      REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev)
+      REAL*8 ztopsw(kdlon), ztoplw(kdlon)
+      REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
+cIM
+      REAL*8 zsollwdown(kdlon)
+c
+      REAL*8 ztopsw0(kdlon), ztoplw0(kdlon)
+      REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
+      REAL*8 zznormcp
+cIM output 3D : SWup, SWdn, LWup, LWdn
+      REAL swdn(klon,kflev+1),swdn0(klon,kflev+1)
+      REAL swup(klon,kflev+1),swup0(klon,kflev+1)
+      REAL lwdn(klon,kflev+1),lwdn0(klon,kflev+1)
+      REAL lwup(klon,kflev+1),lwup0(klon,kflev+1)
+c-OB
+cjq the following quantities are needed for the aerosol radiative forcings
+
+      real topswad(klon), solswad(klon) ! output: aerosol direct forcing at TOA and surface
+      real topswai(klon), solswai(klon) ! output: aerosol indirect forcing atTOA and surface
+      real tau_ae(klon,klev,2), piz_ae(klon,klev,2), cg_ae(klon,klev,2) ! aerosol optical properties (see aeropt.F)
+      real cldtaupi(klon,klev)  ! cloud optical thickness for pre-industrial aerosol concentrations
+                                ! (i.e., with a smaller droplet concentrationand thus larger droplet radii)
+      logical ok_ade, ok_aie    ! switches whether to use aerosol direct (indirect) effects or not
+      real*8 tauae(kdlon,kflev,2) ! aer opt properties
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use
+      REAL*8 POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo
+      REAL*8 ztopswad(kdlon), zsolswad(kdlon) ! Aerosol direct forcing at TOAand surface
+      REAL*8 ztopswai(kdlon), zsolswai(kdlon) ! dito, indirect
+cjq-end
+!rv
+      tauae(:,:,:)=0.
+      pizae(:,:,:)=0.
+      cgae(:,:,:)=0.
+!rv
+      
+c
+c-------------------------------------------
+      nb_gr = klon / kdlon
+      IF (nb_gr*kdlon .NE. klon) THEN
+         PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr
+         CALL abort
+      ENDIF
+      IF (kflev .NE. klev) THEN
+          PRINT*, "kflev differe de klev, kflev, klev"
+          CALL abort
+      ENDIF
+c-------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         heat(i,k)=0.
+         cool(i,k)=0.
+         heat0(i,k)=0.
+         cool0(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      zdist = dist
+c
+cIM anciennes valeurs
+c     RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97
+c
+cIM : on met RCO2, RCH4, RN2O, RCFC11 et RCFC12 dans clesphys.h /lecture ds conf_phys.F90
+c     RCH4 = 1.65E-06* 16.043/28.97
+c     RN2O = 306.E-09* 44.013/28.97
+c     RCFC11 = 280.E-12* 137.3686/28.97
+c     RCFC12 = 484.E-12* 120.9140/28.97
+cIM anciennes valeurs
+c     RCH4 = 1.72E-06* 16.043/28.97
+c     RN2O = 310.E-09* 44.013/28.97
+c
+c     PRINT*,'IMradlwsw : solaire, co2= ', solaire, co2_ppm
+      PSCT = solaire/zdist/zdist
+c
+      DO 99999 j = 1, nb_gr
+      iof = kdlon*(j-1)
+c
+      DO i = 1, kdlon
+         zfract(i) = fract(iof+i)
+         zrmu0(i) = rmu0(iof+i)
+         PALBD(i,1) = alb1(iof+i)
+!         PALBD(i,2) = alb1(iof+i)
+         PALBD(i,2) = alb2(iof+i)
+         PALBP(i,1) = alb1(iof+i)
+!         PALBP(i,2) = alb1(iof+i)
+         PALBP(i,2) = alb2(iof+i)
+cIM cf. JLD pour etre en accord avec ORCHIDEE il faut mettre PEMIS(i) = 0.96
+         PEMIS(i) = 1.0 
+         PVIEW(i) = 1.66
+         PPSOL(i) = paprs(iof+i,1)
+         zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2)) 
+     .             / (pplay(iof+i,1)-pplay(iof+i,2))
+         zx_alpha2 = 1.0 - zx_alpha1
+         PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
+         PTL(i,klev+1) = t(iof+i,klev)
+         PDT0(i) = tsol(iof+i) - PTL(i,1)
+      ENDDO
+      DO k = 2, kflev
+      DO i = 1, kdlon
+         PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
+      ENDDO
+      ENDDO
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
+         PTAVE(i,k) = t(iof+i,k)
+         PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
+         PQS(i,k) = PWV(i,k)
+c wo:    cm.atm (epaisseur en cm dans la situation standard)
+c POZON: kg/kg
+         POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968
+     .               /(paprs(iof+i,k)-paprs(iof+i,k+1))
+     .               *(paprs(iof+i,1)/101325.0)
+         PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDSW(i,k) = cldfra(iof+i,k)
+         PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
+         POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
+         PCG(i,1,k) = 0.865
+         PCG(i,2,k) = 0.910
+c-OB
+cjq Introduced for aerosol indirect forcings.
+cjq The following values use the cloud optical thickness calculated from
+cjq present-day aerosol concentrations whereas the quantities without the
+cjq "A" at the end are for pre-industial (natural-only) aerosol concentrations
+cjq
+         PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k))
+         POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k))
+cjq-end
+      ENDDO
+      ENDDO
+c
+      DO k = 1, kflev+1
+      DO i = 1, kdlon
+         PPMB(i,k) = paprs(iof+i,k)/100.0
+      ENDDO
+      ENDDO
+c
+      DO kk = 1, 5
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PAER(i,k,kk) = 1.0E-15
+      ENDDO
+      ENDDO
+      ENDDO
+c-OB
+      DO k = 1, kflev
+      DO i = 1, kdlon
+        tauae(i,k,1)=tau_ae(iof+i,k,1)
+        pizae(i,k,1)=piz_ae(iof+i,k,1)
+        cgae(i,k,1) =cg_ae(iof+i,k,1)
+        tauae(i,k,2)=tau_ae(iof+i,k,2)
+        pizae(i,k,2)=piz_ae(iof+i,k,2)
+        cgae(i,k,2) =cg_ae(iof+i,k,2)
+      ENDDO
+      ENDDO
+c
+c======================================================================
+cIM ctes ds clesphys.h   CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      CALL LW(
+     .        PPMB, PDP,
+     .        PPSOL,PDT0,PEMIS,
+     .        PTL, PTAVE, PWV, POZON, PAER,
+     .        PCLDLD,PCLDLU,
+     .        PVIEW,
+     .        zcool, zcool0,
+     .        ztoplw,zsollw,ztoplw0,zsollw0,
+     .        zsollwdown,
+     .        ZFLUP, ZFLDN, ZFLUP0,ZFLDN0)
+cIM ctes ds clesphys.h   CALL SW(PSCT, RCO2, zrmu0, zfract,
+      CALL SW(PSCT, zrmu0, zfract,
+     S        PPMB, PDP,
+     S        PPSOL, PALBD, PALBP,
+     S        PTAVE, PWV, PQS, POZON, PAER,
+     S        PCLDSW, PTAU, POMEGA, PCG,
+     S        zheat, zheat0,
+     S        zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,
+     S        ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S        tauae, pizae, cgae, ! aerosol optical properties
+     s        PTAUA, POMEGAA,
+     s        ztopswad,zsolswad,ztopswai,zsolswai, ! diagnosed aerosol forcing
+     J        ok_ade, ok_aie) ! apply aerosol effects or not?
+
+c======================================================================
+      DO i = 1, kdlon
+         radsol(iof+i) = zsolsw(i) + zsollw(i)
+         topsw(iof+i) = ztopsw(i)
+         toplw(iof+i) = ztoplw(i)
+         solsw(iof+i) = zsolsw(i)
+         sollw(iof+i) = zsollw(i)
+         sollwdown(iof+i) = zsollwdown(i)
+cIM
+         DO k = 1, kflev+1
+         lwdn0 ( iof+i,k)   = ZFLDN0 ( i,k)
+         lwdn  ( iof+i,k)   = ZFLDN  ( i,k)
+         lwup0 ( iof+i,k)   = ZFLUP0 ( i,k)
+         lwup  ( iof+i,k)   = ZFLUP  ( i,k)
+         ENDDO
+c
+         topsw0(iof+i) = ztopsw0(i)
+         toplw0(iof+i) = ztoplw0(i)
+         solsw0(iof+i) = zsolsw0(i)
+         sollw0(iof+i) = zsollw0(i)
+         albpla(iof+i) = zalbpla(i)
+cIM
+         DO k = 1, kflev+1
+         swdn0 ( iof+i,k)   = ZFSDN0 ( i,k)
+         swdn  ( iof+i,k)   = ZFSDN  ( i,k)
+         swup0 ( iof+i,k)   = ZFSUP0 ( i,k)
+         swup  ( iof+i,k)   = ZFSUP  ( i,k)
+         ENDDO !k=1, kflev+1
+      ENDDO
+cjq-transform the aerosol forcings, if they have
+cjq to be calculated
+      IF (ok_ade) THEN
+      DO i = 1, kdlon
+         topswad(iof+i) = ztopswad(i)
+         solswad(iof+i) = zsolswad(i)
+      ENDDO
+      ELSE
+      DO i = 1, kdlon
+         topswad(iof+i) = 0.0
+         solswad(iof+i) = 0.0
+      ENDDO
+      ENDIF
+      IF (ok_aie) THEN
+      DO i = 1, kdlon
+         topswai(iof+i) = ztopswai(i)
+         solswai(iof+i) = zsolswai(i)
+      ENDDO
+      ELSE
+      DO i = 1, kdlon
+         topswai(iof+i) = 0.0
+         solswai(iof+i) = 0.0
+      ENDDO
+      ENDIF
+cjq-end
+      DO k = 1, kflev
+c      DO i = 1, kdlon
+c         heat(iof+i,k) = zheat(i,k)
+c         cool(iof+i,k) = zcool(i,k)
+c         heat0(iof+i,k) = zheat0(i,k)
+c         cool0(iof+i,k) = zcool0(i,k)
+c      ENDDO
+      DO i = 1, kdlon
+C        scale factor to take into account the difference between
+C        dry air and watter vapour scpecific heat capacity
+         zznormcp=1.0+RVTMP2*PWV(i,k)
+         heat(iof+i,k) = zheat(i,k)/zznormcp
+         cool(iof+i,k) = zcool(i,k)/zznormcp
+         heat0(iof+i,k) = zheat0(i,k)/zznormcp
+         cool0(iof+i,k) = zcool0(i,k)/zznormcp
+      ENDDO
+      ENDDO
+c
+99999 CONTINUE
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+      SUBROUTINE SW(PSCT, PRMU0, PFRAC, 
+     S              PPMB, PDP, 
+     S              PPSOL, PALBD, PALBP,
+     S              PTAVE, PWV, PQS, POZON, PAER,
+     S              PCLDSW, PTAU, POMEGA, PCG,
+     S              PHEAT, PHEAT0,
+     S              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
+     S              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S              tauae, pizae, cgae,
+     s              PTAUA, POMEGAA,
+     S              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
+     J              ok_ade, ok_aie )
+      USE dimphy      
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOMCST.h"
+C
+C     ------------------------------------------------------------------
+C
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT  ! constante solaire (valeur conseillee: 1370)
+cIM ctes ds clesphys.h   REAL*8 RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+#include "clesphys.h"
+C
+      REAL*8 PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL*8 PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+C
+      REAL*8 PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL*8 PFRAC(KDLON)  ! fraction de la journee
+C
+      REAL*8 PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL*8 PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL*8 PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL*8 POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+C
+      REAL*8 PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL*8 PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+C
+      REAL*8 PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL*8 PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL*8 PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL*8 POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+C
+      REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL*8 PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL*8 PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL*8 PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL*8 PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZOZ(KDLON,KFLEV)
+      REAL*8 ZAKI(KDLON,2)     
+      REAL*8 ZCLD(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON) 
+      REAL*8 ZDSIG(KDLON,KFLEV)
+      REAL*8 ZFACT(KDLON)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFDOWN(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1)
+      REAL*8 ZFUP(KDLON,KFLEV+1)
+      REAL*8 ZRMU(KDLON)
+      REAL*8 ZSEC(KDLON)
+      REAL*8 ZUD(KDLON,5,KFLEV+1)
+      REAL*8 ZCLDSW0(KDLON,KFLEV)
+c
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+C
+      INTEGER inu, jl, jk, i, k, kpl1
+c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+      SAVE itapsw,appel1er
+c$OMP THREADPRIVATE(appel1er)
+c$OMP THREADPRIVATE(itapsw)
+cjq-Introduced for aerosol forcings
+      real*8 flag_aer
+      logical ok_ade, ok_aie    ! use aerosol forcings or not?
+      real*8 tauae(kdlon,kflev,2)  ! aerosol optical properties
+      real*8 pizae(kdlon,kflev,2)  ! (see aeropt.F)
+      real*8 cgae(kdlon,kflev,2)   ! -"-
+      REAL*8 PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+      REAL*8 POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+      REAL*8 PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+      REAL*8 PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+      REAL*8 PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+      REAL*8 PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+cjq - Fluxes including aerosol effects
+      REAL*8,allocatable,save :: ZFSUPAD(:,:)
+c$OMP THREADPRIVATE(ZFSUPAD)
+      REAL*8,allocatable,save :: ZFSDNAD(:,:)
+c$OMP THREADPRIVATE(ZFSDNAD)
+      REAL*8,allocatable,save :: ZFSUPAI(:,:)
+c$OMP THREADPRIVATE(ZFSUPAI)
+      REAL*8,allocatable,save :: ZFSDNAI(:,:)
+c$OMP THREADPRIVATE(ZFSDNAI)
+      logical initialized
+cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+!rv
+      save flag_aer
+c$OMP THREADPRIVATE(flag_aer)
+      data initialized/.false./
+      save initialized
+c$OMP THREADPRIVATE(initialized)
+cjq-end
+      if(.not.initialized) then
+        flag_aer=0.
+        initialized=.TRUE.
+        allocate(ZFSUPAD(KDLON,KFLEV+1))
+        allocate(ZFSDNAD(KDLON,KFLEV+1))
+        allocate(ZFSUPAI(KDLON,KFLEV+1))
+        allocate(ZFSDNAI(KDLON,KFLEV+1))
+	ZFSUPAD(:,:)=0.
+        ZFSDNAD(:,:)=0.
+        ZFSUPAI(:,:)=0.
+        ZFSDNAI(:,:)=0.
+	
+      endif
+!rv
+      
+c
+      IF (appel1er) THEN
+         PRINT*, 'SW calling frequency : ', swpas
+         PRINT*, "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+c
+      DO JK = 1 , KFLEV
+      DO JL = 1, KDLON
+         ZCLDSW0(JL,JK) = 0.0
+         ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
+     .               *PDP(JL,JK)*(101325.0/PPSOL(JL))
+      ENDDO
+      ENDDO
+C
+C
+c clear-sky:
+cIM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+      CALL SWU(PSCT,ZCLDSW0,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+      flag_aer=0.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+
+c cloudy-sky:
+      
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+c      
+      IF (ok_ade) THEN
+c
+c cloudy-sky + aerosol dir OB
+      flag_aer=1.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO 
+      
+      ENDIF ! ok_ade
+      
+      IF (ok_aie) THEN
+         
+cjq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer=1.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAI(JL,JK) = ZFSDN(JL,JK)          
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      ENDIF ! ok_aie      
+cjq -end
+      
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
+     .                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
+     .                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+c-OB
+         PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
+         PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
+c
+         PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
+         PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
+c-fin 
+      ENDDO
+C
+      RETURN
+      END
+c
+cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+      SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+     S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
+     S                PRMU,PSEC,PUD)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT
+cIM ctes ds clesphys.h   REAL*8 RCO2
+#include "clesphys.h"
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 PRMU0(KDLON)
+      REAL*8 PFRAC(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PFACT(KDLON)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(2)
+      REAL*8 ZC1J(KDLON,KFLEV+1)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZN175(KDLON)
+      REAL*8 ZN190(KDLON)
+      REAL*8 ZO175(KDLON)
+      REAL*8 ZO190(KDLON)
+      REAL*8 ZSIGN(KDLON)
+      REAL*8 ZR(KDLON,2) 
+      REAL*8 ZSIGO(KDLON)
+      REAL*8 ZUD(KDLON,2)
+      REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+C
+C* Prescribed Data:
+c
+      REAL*8 ZPDH2O,ZPDUMG
+      SAVE ZPDH2O,ZPDUMG
+c$OMP THREADPRIVATE(ZPDH2O,ZPDUMG)
+      REAL*8 ZPRH2O,ZPRUMG
+      SAVE ZPRH2O,ZPRUMG
+c$OMP THREADPRIVATE(ZPRH2O,ZPRUMG)
+      REAL*8 RTDH2O,RTDUMG
+      SAVE RTDH2O,RTDUMG
+c$OMP THREADPRIVATE(RTDH2O,RTDUMG)
+      REAL*8 RTH2O ,RTUMG
+      SAVE RTH2O ,RTUMG
+c$OMP THREADPRIVATE(RTH2O ,RTUMG)
+      DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /
+      DATA ZPRH2O,ZPRUMG / 30000., 30000. /
+      DATA RTDH2O,RTDUMG /  0.40  , 0.375 /
+      DATA RTH2O ,RTUMG  /  240.  , 240.  /
+C     ------------------------------------------------------------------
+C
+C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+C                 -----------------------------
+C
+ 100  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=2
+C      
+C
+C*         1.1    INITIALIZES QUANTITIES
+C                 ----------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+C
+C*          1.3    AMOUNTS OF ABSORBERS
+C                  --------------------
+C
+ 130  CONTINUE
+C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
+     .             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
+     .             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)
+     S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
+     S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+C      
+C
+C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+C                 -----------------------------------------------
+C
+ 140  CONTINUE
+C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+C
+      CALL SWTT1(2, 2, IIND, ZUD, ZR)
+C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW1S ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW
+     S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD  
+     S  ,  PFD   , PFU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)  
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+      REAL*8 PFD(KDLON,KFLEV+1)
+      REAL*8 PFU(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(4)
+C      
+      REAL*8 ZCGAZ(KDLON,KFLEV) 
+      REAL*8 ZDIFF(KDLON)
+      REAL*8 ZDIRF(KDLON)        
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZR(KDLON,4)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZW(KDLON,4)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+c
+c Prescribed Data:
+c
+      REAL*8 RSUN(2)
+      SAVE RSUN
+c$OMP THREADPRIVATE(RSUN)
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+c$OMP THREADPRIVATE(RRAY)
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C     ------------------------------------------------------------------
+C
+C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+C                 ----------------------- ------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
+     S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
+     S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL
+     S  , PSEC  ,PTAU
+     S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE
+     S  , ZTAUAZ,ZTRA1 ,ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    OZONE ABSORPTION
+C                ----------------
+C
+ 300  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+C      
+C
+C*         3.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 310  CONTINUE
+C
+      JAJ = 2
+C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
+     S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+C
+C
+C*         3.2   UPWARD FLUXES
+C                -------------
+C
+ 320  CONTINUE
+C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
+     S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
+     S          * RSUN(KNU)
+ 325  CONTINUE
+C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW2S ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW
+     S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU
+     S  ,  PUD   ,PWV , PQS
+     S  ,  PFDOWN,PFUP                                            )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+C     A GREY MOLECULAR ABSORPTION
+C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+C     OF ABSORBERS
+C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PQS(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PFDOWN(KDLON,KFLEV+1)
+      REAL*8 PFUP(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND2(2), IIND3(3)
+      REAL*8 ZCGAZ(KDLON,KFLEV)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1) 
+      REAL*8 ZG(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRL(KDLON,8)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZRUEF(KDLON,8)
+      REAL*8 ZR1(KDLON) 
+      REAL*8 ZR2(KDLON,2)
+      REAL*8 ZR3(KDLON,3)
+      REAL*8 ZR4(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZS(KDLON)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)   
+      REAL*8 ZW1(KDLON)
+      REAL*8 ZW2(KDLON,2)
+      REAL*8 ZW3(KDLON,3)
+      REAL*8 ZW4(KDLON)
+      REAL*8 ZW5(KDLON)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+C
+C* Prescribed Data:
+C
+      REAL*8 RSUN(2)
+      SAVE RSUN
+c$OMP THREADPRIVATE(RSUN)
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+c$OMP THREADPRIVATE(RRAY)
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C
+C     ------------------------------------------------------------------
+C
+C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+C                 -------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1
+     S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1
+     S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC 
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL
+     S  , PSEC  , PTAU
+     S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE
+     S  , ZTAUAZ, ZTRA1 , ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+C                ------------------------------------------------------
+C
+ 300  CONTINUE
+C
+      JN = 2
+C
+      DO 361 JABS=1,2
+C
+C
+C*         3.1  SURFACE CONDITIONS
+C               ------------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+C
+C
+C*         3.2  INTRODUCING CLOUD EFFECTS
+C               -------------------------
+C
+ 320  CONTINUE
+C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
+     S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
+     S               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+C
+      CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
+     S          ZRE1, ZRE2, ZTR1, ZTR2)
+C
+      DO 323 JL = 1, KDLON
+C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
+     S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
+     S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
+     S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
+     S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
+     S             + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
+     S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
+     S              * ZREFZ(JL,1,JKM1)))
+     S              * ZG(JL) * (1. -ZRNEB(JL))
+C
+ 323  CONTINUE
+ 324  CONTINUE
+C
+C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C               -------------------------------------------------
+C
+ 330  CONTINUE
+C
+      DO 351 JREF=1,2
+C
+      JN = JN + 1
+C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         4.    INVERT GREY AND CONTINUUM FLUXES
+C                --------------------------------
+C
+ 400  CONTINUE
+C
+C
+C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+C                ---------------------------------------------
+C
+ 410  CONTINUE
+C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+C
+C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+C                 ---------------------------------------------
+C
+ 420  CONTINUE
+C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+C
+C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+C                 --------------------------
+C
+ 4210 CONTINUE
+C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+C
+C*         4.2.2  TRANSMISSION FUNCTION
+C                 ---------------------
+C
+ 4220 CONTINUE
+C
+      CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
+C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+C
+C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+C                 ------------------------------------------------------
+C
+ 430  CONTINUE
+C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
+     S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
+     S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+C                ----------------------------------------
+C
+ 500  CONTINUE
+C
+C
+C*         5.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 510  CONTINUE
+C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 513 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+C
+C
+C*         5.2   UPWARD FLUXES
+C                -------------
+C
+ 520  CONTINUE
+C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 527 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+C                 --------------------------------------------------
+C
+ 600  CONTINUE
+      IABS=3
+C
+C*         6.1    DOWNWARD FLUXES
+C                 ---------------
+C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
+     S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
+     S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+C
+C
+C*         6.2    UPWARD FLUXES
+C                 -------------
+C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
+     S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
+     S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWCLR  ( KNU
+     S  , PAER  , flag_aer, tauae, pizae, cgae
+     S  , PALBP , PDSIG , PRAYL , PSEC
+     S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ  
+     S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CLEAR-SKY COLUMN
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 94-11-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+C
+      REAL*8 PCGAZ(KDLON,KFLEV)     
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMU0(KDLON,KFLEV+1)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC0I(KDLON,KFLEV+1)       
+      REAL*8 ZCLE0(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS0(KDLON)
+      REAL*8 ZSCAT(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL*8 ZBMU0, ZBMU1, ZRE11
+C
+C* Prescribed Data for Aerosols:
+C
+      REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
+      SAVE TAUA, RPIZA, RCGA
+c$OMP THREADPRIVATE(TAUA, RPIZA, RCGA)
+      DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
+     S .730719, .912819, .725059, .745405, .682188 ,
+     S .730719, .912819, .725059, .745405, .682188 /
+      DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
+     S .872212, .982545, .623143, .944887, .997975 ,
+     S .872212, .982545, .623143, .944887, .997975 /
+      DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
+     S .647596, .739002, .580845, .662657, .624246 ,
+     S .647596, .739002, .580845, .662657, .624246 /
+C     ------------------------------------------------------------------
+C
+C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+C                --------------------------------------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+      DO 108 JK = 1 , KFLEV
+c-OB
+c      DO 104 JL = 1, KDLON
+c      PCGAZ(JL,JK) = 0.
+c      PPIZAZ(JL,JK) =  0.
+c      PTAUAZ(JL,JK) = 0.
+c 104  CONTINUE
+c-OB
+c      DO 106 JAE=1,5
+c      DO 105 JL = 1, KDLON
+c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+c 105  CONTINUE
+c 106  CONTINUE
+c-OB
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
+      PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
+      PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
+ 105  CONTINUE
+C
+      IF (flag_aer.GT.0) THEN
+c-OB
+      DO 107 JL = 1, KDLON
+c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
+     S                       / (1. - PPIZAZ(JL,JK) * ZFF)
+ 107  CONTINUE
+      ELSE
+      DO JL = 1, KDLON
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END DO
+      END IF   ! check flag_aer
+c     107  CONTINUE
+c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+C
+ 108  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
+     S            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
+     S  , PSEC  , PTAU
+     S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
+     S  , PTAUAZ, PTRA1 , PTRA2 )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CONTINUUM SCATTERING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+C
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMUE(KDLON,KFLEV+1)
+      REAL*8 PCGAZ(KDLON,KFLEV)
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC1I(KDLON,KFLEV+1)
+      REAL*8 ZCLEQ(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS1(KDLON)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)
+C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
+C
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
+     S            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.3  EFFECT OF CLOUD LAYER
+C               ---------------------
+C
+ 330  CONTINUE
+C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
+     S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+C machine
+C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+C
+      CALL SWDE(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
+     S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+C
+      DO 345 JL = 1, KDLON
+C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               * (1.-ZRNEB(JL))
+C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
+     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
+     S                 PRE1,PRE2,PTR1,PTR2)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+C
+C     METHOD.
+C     -------
+C
+C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      REAL*8 PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL*8 PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL*8 PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL*8 PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL*8 PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL*8 PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER jl
+      REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
+      REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL*8 ZRI0B, ZRI1B
+      REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
+C     ------------------------------------------------------------------
+C
+C*         1.      DELTA-EDDINGTON CALCULATIONS
+C
+ 100  CONTINUE
+C
+      DO 131 JL   =   1, KDLON
+C
+C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+C
+ 110  CONTINUE
+C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+CMAF      ZARG=MIN(ZTOP/PRMUZ(JL),200.)
+      ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
+      ZEXMU0=EXP(-ZARG)
+CMAF      ZARG2=MIN(ZRK*ZTOP,200.)
+      ZARG2=MIN(ZRK*ZTOP,2.0d+2)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+C
+C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+C
+ 120  CONTINUE
+C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+C
+C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+C
+ 130  CONTINUE
+C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+C
+ 131  CONTINUE
+      RETURN
+      END
+      SUBROUTINE SWTT (KNU,KA,PU,PTR)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS
+C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL*8 PU(KDLON)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+c$OMP THREADPRIVATE(APAD, BPAD, D)
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
+     S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
+     S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
+     S      * ( APAD(KNU,KA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
+     S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
+     S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
+     S      * ( BPAD(KNU,KA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 95-01-20
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL*8 PU(KDLON,KABS)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON)
+      REAL*8 ZR2(KDLON)
+      REAL*8 ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+c$OMP THREADPRIVATE(APAD, BPAD, D)
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
+     S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
+     S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
+     S      * ( APAD(KNU,IA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
+     S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
+     S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
+     S      * ( BPAD(KNU,IA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+C
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      SUBROUTINE LW(
+     .              PPMB, PDP,
+     .              PPSOL,PDT0,PEMIS,
+     .              PTL, PTAVE, PWV, POZON, PAER,
+     .              PCLDLD,PCLDLU,
+     .              PVIEW,
+     .              PCOLR, PCOLR0,
+     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
+     .              psollwdown,
+cIM  .              psollwdown,psollwdownclr,
+cIM  .              ptoplwdown,ptoplwdownclr)
+     .              plwup, plwdn, plwup0, plwdn0)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+cIM ctes ds clesphys.h
+c     REAL*8 RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+c     REAL*8 RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+c     REAL*8 RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+c     REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+c     REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+#include "clesphys.h"
+      REAL*8 PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL*8 PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL*8 PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL*8 PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL*8 PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL*8 PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL*8 POZON(KDLON,KFLEV)   ! O3 CONCENTRATION (kg/kg)
+      REAL*8 PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL*8 PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL*8 PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL*8 PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL*8 PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+C
+      REAL*8 PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL*8 PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL*8 PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL*8 PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      REAL*8 PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+c Rajout LF
+      real*8 psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
+c Rajout IM
+cIM   real*8 psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
+cIM   real*8 ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
+cIM   real*8 ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
+cIM
+      REAL*8 plwup(KDLON,KFLEV+1)  ! LW up total sky
+      REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky
+      REAL*8 plwdn(KDLON,KFLEV+1)  ! LW down total sky
+      REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky
+C-------------------------------------------------------------------------
+      REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZOZ(KDLON,KFLEV)
+c
+cym      REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+cym      REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+cym      REAL*8 ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+cym      REAL*8 ZBSUI(KDLON)                    ! Intermediate variable
+cym      REAL*8,ZCTS(KDLON,KFLEV)               ! Intermediate variable
+cym      REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+      REAL*8,allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL*8,allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8,allocatable,save :: ZBINT(:,:)            ! Intermediate variable
+      REAL*8,allocatable,save :: ZBSUI(:)                    ! Intermediate variable
+      REAL*8,allocatable,save :: ZCTS(:,:)               ! Intermediate variable
+      REAL*8,allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
+c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+c
+      INTEGER ilim, i, k, kpl1
+C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+
+C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         PRINT*, "LW clear-sky calling frequency: ", lw0pas
+         PRINT*, "LW cloudy-sky calling frequency: ", lwpas
+         PRINT*, "   In general, they should be 1"
+cym
+	 allocate(ZFLUX(KDLON,2,KFLEV+1) )
+         allocate(ZFLUC(KDLON,2,KFLEV+1) )
+         allocate(ZBINT(KDLON,KFLEV+1))
+         allocate(ZBSUI(KDLON))
+         allocate(ZCTS(KDLON,KFLEV))
+         allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
+         appel1er=.FALSE.
+      ENDIF
+C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+      DO k = 1, KFLEV  ! convertir ozone de kg/kg en pa/pa
+      DO i = 1, KDLON
+c convertir ozone de kg/kg en pa (modif MPL 100505)
+         ZOZ(i,k) = POZON(i,k)*PDP(i,k) * RMD/RMO3
+c        print *,'LW: ZOZ*10**6=',ZOZ(i,k)*1000000.
+      ENDDO
+      ENDDO
+cIM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+      CALL LWU(
+     S         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
+     S          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
+     S         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
+     S         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
+     .                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
+     .                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+c
+         PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
+         PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
+c
+cIM attention aux signes !; LWtop >0, LWdn < 0
+         DO k = 1, KFLEV+1
+           plwup(i,k) = ZFLUX(i,1,k)
+           plwup0(i,k) = ZFLUC(i,1,k)
+           plwdn(i,k) = ZFLUX(i,2,k)
+           plwdn0(i,k) = ZFLUC(i,2,k)
+         ENDDO
+      ENDDO
+C     ------------------------------------------------------------------
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+      SUBROUTINE LWU(
+     S               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
+     S               PABCU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+C           TEMPERATURE EFFECTS
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+cIM ctes ds clesphys.h
+c     REAL*8 RCO2
+c     REAL*8 RCH4, RN2O, RCFC11, RCFC12
+#include "clesphys.h"
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PVIEW(KDLON)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+C
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZDUC(KDLON,3*KFLEV+1)
+      REAL*8 ZPHIO(KDLON)
+      REAL*8 ZPSC2(KDLON)
+      REAL*8 ZPSC3(KDLON)
+      REAL*8 ZPSH1(KDLON)
+      REAL*8 ZPSH2(KDLON)
+      REAL*8 ZPSH3(KDLON)
+      REAL*8 ZPSH4(KDLON)
+      REAL*8 ZPSH5(KDLON)
+      REAL*8 ZPSH6(KDLON)
+      REAL*8 ZPSIO(KDLON)
+      REAL*8 ZTCON(KDLON)
+      REAL*8 ZPHM6(KDLON)
+      REAL*8 ZPSM6(KDLON)
+      REAL*8 ZPHN6(KDLON)
+      REAL*8 ZPSN6(KDLON)
+      REAL*8 ZSSIG(KDLON,3*KFLEV+1)
+      REAL*8 ZTAVI(KDLON)
+      REAL*8 ZUAER(KDLON,Ninter)
+      REAL*8 ZXOZ(KDLON)
+      REAL*8 ZXWV(KDLON)
+C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL*8 zfppw, ztx, ztx2, zzably
+      REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL*8 zcac8, zcbc8
+      REAL*8 zalup, zdiff
+c
+      REAL*8 PVGCO2, PVGH2O, PVGO3
+C
+      REAL*8 R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+c
+c Used Data Block:
+c
+      REAL*8 TREF
+      SAVE TREF
+c$OMP THREADPRIVATE(TREF)
+      REAL*8 RT1(2)
+      SAVE RT1
+c$OMP THREADPRIVATE(RT1)
+      REAL*8 RAER(5,5)
+      SAVE RAER
+c$OMP THREADPRIVATE(RAER)
+      REAL*8 AT(8,3), BT(8,3)
+      SAVE AT, BT
+c$OMP THREADPRIVATE(AT, BT)
+      REAL*8 OCT(4)
+      SAVE OCT
+c$OMP THREADPRIVATE(OCT)
+      DATA TREF /250.0/
+      DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
+      DATA RAER / .038520, .037196, .040532, .054934, .038520
+     1          , .12613 , .18313 , .10357 , .064106, .126130
+     2          , .012579, .013649, .018652, .025181, .012579
+     3          , .011890, .016142, .021105, .028908, .011890
+     4          , .013792, .026810, .052203, .066338, .013792 /
+      DATA (AT(1,IR),IR=1,3) /
+     S 0.298199E-02,-.394023E-03,0.319566E-04 /
+      DATA (BT(1,IR),IR=1,3) /
+     S-0.106432E-04,0.660324E-06,0.174356E-06 /
+      DATA (AT(2,IR),IR=1,3) /
+     S 0.143676E-01,0.366501E-02,-.160822E-02 /
+      DATA (BT(2,IR),IR=1,3) /
+     S-0.553979E-04,-.101701E-04,0.920868E-05 /
+      DATA (AT(3,IR),IR=1,3) /
+     S 0.197861E-01,0.315541E-02,-.174547E-02 /
+      DATA (BT(3,IR),IR=1,3) /
+     S-0.877012E-04,0.513302E-04,0.523138E-06 /
+      DATA (AT(4,IR),IR=1,3) /
+     S 0.289560E-01,-.208807E-02,-.121943E-02 /
+      DATA (BT(4,IR),IR=1,3) /
+     S-0.165960E-03,0.157704E-03,-.146427E-04 /
+      DATA (AT(5,IR),IR=1,3) /
+     S 0.103800E-01,0.436296E-02,-.161431E-02 /
+      DATA (BT(5,IR),IR=1,3) /
+     S -.276744E-04,-.327381E-04,0.127646E-04 /
+      DATA (AT(6,IR),IR=1,3) /
+     S 0.868859E-02,-.972752E-03,0.000000E-00 /
+      DATA (BT(6,IR),IR=1,3) /
+     S -.278412E-04,-.713940E-06,0.117469E-05 /
+      DATA (AT(7,IR),IR=1,3) /
+     S 0.250073E-03,0.455875E-03,0.109242E-03 /
+      DATA (BT(7,IR),IR=1,3) /
+     S 0.199846E-05,-.216313E-05,0.175991E-06 /
+      DATA (AT(8,IR),IR=1,3) /
+     S 0.307423E-01,0.110879E-02,-.322172E-03 /
+      DATA (BT(8,IR),IR=1,3) /
+     S-0.108482E-03,0.258096E-05,-.814575E-06 /
+c
+      DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
+C-----------------------------------------------------------------------
+c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+C
+C
+C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+C                ------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
+     S  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+C                --------------------------------------------------
+C
+ 400  CONTINUE
+C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
+     S                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+C                --------------------------------------------------
+C
+ 500  CONTINUE
+C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+C
+C
+C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+C               --------------------------------------------------
+C
+ 510  CONTINUE
+C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
+     S      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
+     S      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
+     S      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+C
+C
+C
+C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+C               --------------------------------------------------
+C
+ 520  CONTINUE
+C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+CMAF      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+CMAF      ZUP   = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
+      ZUP   = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
+     S                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
+     S                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
+     S                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
+     S                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
+     S                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
+     S                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
+     S                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
+     S                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
+     S                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+C
+      PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S               +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+      PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+      PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S               +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+      PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S               +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+C
+      PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+      PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+ 523  CONTINUE
+ 524  CONTINUE
+C
+ 529  CONTINUE
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
+     S                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C     PURPOSE.
+C     --------
+C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+C           SAVING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+C                                          MEMORY)
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER KLIM
+C
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PDT0(KDLON)
+      REAL*8 PEMIS(KDLON)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PTL(KDLON,KFLEV+1)
+      REAL*8 PTAVE(KDLON,KFLEV)
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1)
+C     
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 PBINT(KDLON,KFLEV+1)
+      REAL*8 PBSUI(KDLON)
+      REAL*8 PCTS(KDLON,KFLEV)
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+C
+C-------------------------------------------------------------------------
+C
+C* LOCAL VARIABLES:
+      REAL*8 ZB(KDLON,Ninter,KFLEV+1)
+      REAL*8 ZBSUR(KDLON,Ninter)
+      REAL*8 ZBTOP(KDLON,Ninter)
+      REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL*8 ZGA(KDLON,8,2,KFLEV)
+      REAL*8 ZGB(KDLON,8,2,KFLEV)
+      REAL*8 ZGASUR(KDLON,8,2)
+      REAL*8 ZGBSUR(KDLON,8,2)
+      REAL*8 ZGATOP(KDLON,8,2)
+      REAL*8 ZGBTOP(KDLON,8,2)
+C
+      INTEGER nuaer, ntraer
+C     ------------------------------------------------------------------
+C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB(PDT0,PTAVE,PTL,
+     S          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
+     S          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+C     ------------------------------------------------------------------
+C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV(NUAER,NTRAER, KLIM
+     R  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
+     R  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+C     ------------------------------------------------------------------
+      RETURN
+      END
+      SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
+     R               PBINT,PBSUIN,PCTS,PCNTRB,
+     S               PFLUX)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+C           RADIANCES
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+C PFLUC
+C     ==== OUTPUTS ===
+C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+C                     1  ==>  UPWARD   FLUX TOTAL
+C                     2  ==>  DOWNWARD FLUX TOTAL
+C
+C     METHOD.
+C     -------
+C
+C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+C     CLOUDS
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER klim
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL*8 PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+c
+      REAL*8 PCLDLD(KDLON,KFLEV)
+      REAL*8 PCLDLU(KDLON,KFLEV)
+      REAL*8 PEMIS(KDLON)
+C
+      REAL*8 PFLUX(KDLON,2,KFLEV+1)
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+C
+      REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
+     S  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
+     S  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
+C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL*8 zcfrac
+C     ------------------------------------------------------------------
+C
+C*         1.     INITIALIZATION
+C                 --------------
+C
+ 100  CONTINUE
+C
+      IMAXC = 0
+C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+C
+C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+C                 -------------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+CGM*******
+      IMAXC=KFLEV
+CGM*******
+C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+C                  ---------------------------------------
+C
+      IF (IMAXC.GT.0) THEN
+C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+C
+C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+C                  ------------------------------
+C
+ 200  CONTINUE
+C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+C
+C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+C                  ----------------------------------------------
+C
+ 210  CONTINUE
+C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+C
+C*         2.1.1   ABOVE THE CLOUD
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+C
+C*         2.1.2   BELOW THE CLOUD
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+C
+ 213     CONTINUE
+C
+C
+C*         2.2     CLOUD COVER MATRIX
+C                  ------------------
+C
+C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+C
+ 220  CONTINUE
+C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+C
+C
+C
+C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 240  CONTINUE
+C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+C
+C
+C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 250  CONTINUE
+C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+C
+C
+C
+C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+C                  ----------------------------------------------
+C
+ 300  CONTINUE
+C
+C*         3.1     DOWNWARD FLUXES
+C                  ---------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+C
+      DO 317 JK1 = KFLEV , 1 , -1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+C
+ 317  CONTINUE
+C
+C
+C
+C
+C*         3.2     UPWARD FLUX AT THE SURFACE
+C                  --------------------------
+C
+ 320  CONTINUE
+C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+C
+C
+C
+C*         3.3     UPWARD FLUXES
+C                  -------------
+C
+ 330  CONTINUE
+C
+      DO 337 JK1 = 2 , KFLEV+1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+C
+ 337  CONTINUE
+C
+C
+      END IF
+C
+C
+C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+C
+ 230  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+C
+      RETURN
+      END
+      SUBROUTINE LWB(PDT0,PTAVE,PTL
+     S  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
+     S  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES PLANCK FUNCTIONS
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+C     ==== OUTPUTS ===
+C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C
+C-----------------------------------------------------------------------
+C
+C ARGUMENTS:
+C
+      REAL*8 PDT0(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PTL(KDLON,KFLEV+1)
+C
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+C-------------------------------------------------------------------------
+C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL*8 zdsto1, zdstox, zdst1, zdstx
+c
+C* Quelques parametres:
+      REAL*8 TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL*8 TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+C
+C* Used Data Block:
+      REAL*8 TINTP(11)
+      SAVE TINTP
+c$OMP THREADPRIVATE(TINTP)
+      REAL*8 GA(11,16,3), GB(11,16,3)
+      SAVE GA, GB
+c$OMP THREADPRIVATE(GA, GB)
+      REAL*8 XP(6,6)
+      SAVE XP
+c$OMP THREADPRIVATE(XP)
+c
+      DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+     S             262.5, 275., 287.5, 300., 312.5 /
+C-----------------------------------------------------------------------
+C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+C
+C
+C
+C
+C-- R.D. -- G = - 0.2 SLA
+C
+C
+C----- INTERVAL = 1 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+      DATA (GB( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+      DATA (GA( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+      DATA (GB( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+      DATA (GB( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+      DATA (GA( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+      DATA (GB( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+      DATA (GB( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+      DATA (GA( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+      DATA (GB( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+      DATA (GB( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+      DATA (GA( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+      DATA (GB( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+      DATA (GB( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+      DATA (GA( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+      DATA (GB( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+      DATA (GB( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+      DATA (GA( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+      DATA (GB( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+      DATA (GB( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+      DATA (GA( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+      DATA (GB( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+      DATA (GB( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+      DATA (GA( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+      DATA (GB( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+      DATA (GB( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+      DATA (GA( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+      DATA (GB( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+      DATA (GB(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+      DATA (GA(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+      DATA (GB(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+      DATA (GB(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+      DATA (GA(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+      DATA (GB(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+C
+C
+C
+C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+C
+C
+C
+C
+C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+C
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+      DATA (GB( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+      DATA (GA( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+      DATA (GB( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+      DATA (GB( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+      DATA (GA( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+      DATA (GB( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+      DATA (GB( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+      DATA (GA( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+      DATA (GB( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+      DATA (GB( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+      DATA (GA( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+      DATA (GB( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+      DATA (GB( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+      DATA (GA( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+      DATA (GB( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+      DATA (GB( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+      DATA (GA( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+      DATA (GB( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+      DATA (GB( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+      DATA (GA( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+      DATA (GB( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+      DATA (GB( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+      DATA (GA( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+      DATA (GB( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+      DATA (GB( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+      DATA (GA( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+      DATA (GB( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+      DATA (GB(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+      DATA (GA(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+      DATA (GB(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+      DATA (GB(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+      DATA (GA(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+      DATA (GB(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+C
+C
+C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C
+C--- G = 3.875E-03 ---------------
+C
+C----- INTERVAL = 3 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+      DATA (GB( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+      DATA (GA( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+      DATA (GB( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+      DATA (GB( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+      DATA (GA( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+      DATA (GB( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+      DATA (GB( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+      DATA (GA( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+      DATA (GB( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+      DATA (GB( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+      DATA (GA( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+      DATA (GB( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+      DATA (GB( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+      DATA (GA( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+      DATA (GB( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+      DATA (GB( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+      DATA (GA( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+      DATA (GB( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+      DATA (GB( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+      DATA (GA( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+      DATA (GB( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+      DATA (GB( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+      DATA (GA( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+      DATA (GB( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+      DATA (GB( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+      DATA (GA( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+      DATA (GB( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+      DATA (GB(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+      DATA (GA(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+      DATA (GB(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+      DATA (GB(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+      DATA (GA(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+      DATA (GB(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+C
+C
+C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+C
+C-- G = 3.6E-03
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+      DATA (GB( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+      DATA (GA( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+      DATA (GB( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+      DATA (GB( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+      DATA (GA( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+      DATA (GB( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+      DATA (GB( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+      DATA (GA( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+      DATA (GB( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+      DATA (GB( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+      DATA (GA( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+      DATA (GB( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+      DATA (GB( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+      DATA (GA( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+      DATA (GB( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+      DATA (GB( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+      DATA (GA( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+      DATA (GB( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+      DATA (GB( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+      DATA (GA( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+      DATA (GB( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+      DATA (GB( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+      DATA (GA( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+      DATA (GB( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+      DATA (GB( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+      DATA (GA( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+      DATA (GB( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+      DATA (GB(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+      DATA (GA(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+      DATA (GB(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+      DATA (GB(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+      DATA (GA(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+      DATA (GB(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+C
+C
+C
+C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+C
+C-- WATER VAPOR --- 350 - 500 CM-1
+C
+C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+C
+C----- INTERVAL = 5 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+      DATA (GB( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+      DATA (GA( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+      DATA (GB( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+      DATA (GB( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+      DATA (GA( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+      DATA (GB( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+      DATA (GB( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+      DATA (GA( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+      DATA (GB( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+      DATA (GB( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+      DATA (GA( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+      DATA (GB( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+      DATA (GB( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+      DATA (GA( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+      DATA (GB( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+      DATA (GB( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+      DATA (GA( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+      DATA (GB( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+      DATA (GB( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+      DATA (GA( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+      DATA (GB( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+      DATA (GB( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+      DATA (GA( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+      DATA (GB( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+      DATA (GB( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+      DATA (GA( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+      DATA (GB( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+      DATA (GB(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+      DATA (GA(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+      DATA (GB(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+      DATA (GB(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+      DATA (GA(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+      DATA (GB(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+C
+C
+C
+C
+C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+C--- G = 0.0
+C
+C
+C----- INTERVAL = 6 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+      DATA (GB( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+      DATA (GA( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+      DATA (GB( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+      DATA (GB( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+      DATA (GA( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+      DATA (GB( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+      DATA (GB( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+      DATA (GA( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+      DATA (GB( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+      DATA (GB( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+      DATA (GA( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+      DATA (GB( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+      DATA (GB( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+      DATA (GA( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+      DATA (GB( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+      DATA (GB( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+      DATA (GA( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+      DATA (GB( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+      DATA (GB( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+      DATA (GA( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+      DATA (GB( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+      DATA (GB( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+      DATA (GA( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+      DATA (GB( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+      DATA (GB( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+      DATA (GA( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+      DATA (GB( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+      DATA (GB(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+      DATA (GA(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+      DATA (GB(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+      DATA (GB(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+      DATA (GA(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+      DATA (GB(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C-- END WATER VAPOR
+C
+C
+C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+C
+C
+C
+C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+      DATA (GB( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+      DATA (GA( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+      DATA (GB( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+      DATA (GB( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+      DATA (GA( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+      DATA (GB( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+      DATA (GB( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+      DATA (GA( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+      DATA (GB( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+      DATA (GB( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+      DATA (GA( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+      DATA (GB( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+      DATA (GB( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+      DATA (GA( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+      DATA (GB( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+      DATA (GB( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+      DATA (GA( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+      DATA (GB( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+      DATA (GB( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+      DATA (GA( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+      DATA (GB( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+      DATA (GB( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+      DATA (GA( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+      DATA (GB( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+      DATA (GB( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+      DATA (GA( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+      DATA (GB( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+      DATA (GB(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+      DATA (GA(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+      DATA (GB(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+      DATA (GB(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+      DATA (GA(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+      DATA (GB(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C-- G = 0.0
+C
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+      DATA (GB( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+      DATA (GA( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+      DATA (GB( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+      DATA (GB( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+      DATA (GA( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+      DATA (GB( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+      DATA (GB( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+      DATA (GA( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+      DATA (GB( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+      DATA (GB( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+      DATA (GA( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+      DATA (GB( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+      DATA (GB( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+      DATA (GA( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+      DATA (GB( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+      DATA (GB( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+      DATA (GA( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+      DATA (GB( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+      DATA (GB( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+      DATA (GA( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+      DATA (GB( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+      DATA (GB( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+      DATA (GA( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+      DATA (GB( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+      DATA (GB( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+      DATA (GA( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+      DATA (GB( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+      DATA (GB(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+      DATA (GA(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+      DATA (GB(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+      DATA (GB(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+      DATA (GA(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+      DATA (GB(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+
+C     ------------------------------------------------------------------
+      DATA (( XP(  J,K),J=1,6),       K=1,6) /
+     S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+     S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+     S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+     S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+     S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+     S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+     S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+     S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+     S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+     S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+     S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+     S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+C
+C
+C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+C                  ------------------------------
+C
+ 100  CONTINUE
+C
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+C
+      DO 141 JNU=1,Ninter
+C
+C
+C*         1.1   LEVELS FROM SURFACE TO KFLEV
+C                ----------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C
+C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+C                ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+C
+C
+C*         1.3   GRADIENTS IN SUB-LAYERS
+C                -----------------------
+C
+ 130  CONTINUE
+C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+C
+ 141  CONTINUE
+C
+C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+C                ---------------------------------------------
+C
+ 200  CONTINUE
+C
+C
+ 210  CONTINUE
+C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+C
+ 220  CONTINUE
+C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWV(KUAER,KTRAER, KLIM
+     R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+C           FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+C                      -  THE DISTANT LAYERS
+C                      -  THE BOUNDARY TERMS
+C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+C-----------------------------------------------------------------------
+C LOCAL VARIABLES:
+      REAL*8 ZADJD(KDLON,KFLEV+1)
+      REAL*8 ZADJU(KDLON,KFLEV+1)
+      REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
+      REAL*8 ZDISD(KDLON,KFLEV+1)
+      REAL*8 ZDISU(KDLON,KFLEV+1)
+C
+      INTEGER jk, jl
+C-----------------------------------------------------------------------
+C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C* CONTRIBUTION FROM ADJACENT LAYERS
+C
+      CALL LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+C* CONTRIBUTION FROM DISTANT LAYERS
+C
+      CALL LWVD(KUAER,KTRAER
+     R  , PABCU,ZDBDT,PGA,PGB
+     S  , PCNTRB,ZDISD,ZDISU)
+C
+C* EXCHANGE WITH THE BOUNDARIES
+C
+      CALL LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
+     R  , ZDISD,ZDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
+     R  , PDISD,PDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+C           INTEGRATION
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+C     ATMOSPHERE
+C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZBGND(KDLON)
+      REAL*8 ZFD(KDLON)
+      REAL*8  ZFN10(KDLON)
+      REAL*8 ZFU(KDLON)
+      REAL*8  ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8  ZUU(KDLON,NUA) 
+      REAL*8 ZCNSOL(KDLON)
+      REAL*8 ZCNTOP(KDLON)
+C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL*8 zctstr
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+C                  -----------------------------------
+C
+ 230  CONTINUE
+C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+C
+C
+      CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+C
+ 235  CONTINUE
+C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)
+     1   + PBTOP(JL,2)
+     2   + PBTOP(JL,3)
+     3   + PBTOP(JL,4)
+     4   + PBTOP(JL,5)
+     5   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+C
+C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+C                  ---------------------------------------
+C
+ 240  CONTINUE
+C
+C
+C*         2.4.1   INITIALIZATION
+C                  --------------
+C
+ 2410 CONTINUE
+C
+      JLIM = KFLEV
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+C
+C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+C                  -----------------------------
+C
+ 2420   CONTINUE
+C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+C
+C
+        CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =
+     1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
+     1       *(ZTT1(JL,1)           *ZTT1(JL,10)
+     1       - ZTT (JL,1)           *ZTT (JL,10))
+     2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
+     2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
+     2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
+     3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
+     3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
+     3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
+     4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
+     4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
+     4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
+     5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
+     5       *(ZTT1(JL,3)           *ZTT1(JL,14)
+     5       - ZTT (JL,3)           *ZTT (JL,14))
+     6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
+     6       *(ZTT1(JL,6)           *ZTT1(JL,15)
+     6       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+C
+C
+C*         2.5     EXCHANGE WITH LOWER LIMIT
+C                  -------------------------
+C
+ 250  CONTINUE
+C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
+     S               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)
+     1 +PBSUR(JL,2)
+     2 +PBSUR(JL,3)
+     3 +PBSUR(JL,4)
+     4 +PBSUR(JL,5)
+     5 +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+C
+C
+      CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+C
+C
+ 257  CONTINUE
+C
+C
+C
+C*         2.7     CLEAR-SKY FLUXES
+C                  ----------------
+C
+ 270  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWVD(KUAER,KTRAER
+     S  , PABCU,PDBDT
+     R  , PGA,PGB
+     S  , PCNTRB,PDISD,PDISU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL*8 PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL*8 zww, zdzxdg, zdzxmg
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+C                  ---------------------------------
+C
+ 220  CONTINUE
+C
+C
+C*         2.2.1   DISTANT AND ABOVE LAYERS
+C                  ------------------------
+C
+ 2210 CONTINUE
+C
+C
+C
+C*         2.2.2   FIRST UPPER LEVEL
+C                  -----------------
+C
+ 2220 CONTINUE
+C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+C
+      CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
+     2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+C
+C
+C
+C*         2.2.3   HIGHER UP
+C                  ---------
+C
+ 2230 CONTINUE
+C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+C
+C
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C
+C*         2.2.4   DISTANT AND BELOW LAYERS
+C                  ------------------------
+C
+ 2240 CONTINUE
+C
+C
+C
+C*         2.2.5   FIRST LOWER LEVEL
+C                  -----------------
+C
+ 2250 CONTINUE
+C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+C
+C
+      CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
+     2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+C
+C
+C
+C*         2.2.6   DOWN BELOW
+C                  ----------
+C
+ 2260 CONTINUE
+C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+C
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+C
+C
+ 227  CONTINUE
+ 228  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , PADJD,PADJU,PCNTRB,PDBDT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+C
+C* LOCAL ARRAYS:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8 ZUU(KDLON,NUA)
+C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL*8 zwtr
+c
+C* Data Block:
+c
+      REAL*8 WG1(2)
+      SAVE WG1
+c$OMP THREADPRIVATE(WG1)
+      DATA (WG1(jk),jk=1,2) /1.0, 1.0/
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+C
+C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+C                  ---------------------------------
+C
+ 210  CONTINUE
+C
+      DO 215 JK = 1 , KFLEV
+C
+C*         2.1.1   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+C
+C*         2.1.2   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+C
+ 213  CONTINUE
+C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+C
+ 215  CONTINUE
+C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+C
+      RETURN
+C
+      END
+      SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PUU(KDLON,NUA)
+      REAL*8 PTT(KDLON,NTRA)
+      REAL*8 PGA(KDLON,8,2)
+      REAL*8 PGB(KDLON,8,2)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL*8 zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL*8 zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+c     NEXOTIC=1
+c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER ja, jl
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL*8 zxch4, zych4, zsqh41, zodh41
+      REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL*8 zuu11, zuu12
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
+     S         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/radopt.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/radopt.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/radopt.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+      LOGICAL LEVOIGT
+      PARAMETER (LEVOIGT=.FALSE.)
+      INTEGER NOVLP
+      PARAMETER (NOVLP=1)
+      INTEGER KAER
+      PARAMETER (KAER=0)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ran0_vec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ran0_vec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ran0_vec.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      subroutine ran0_vec(npoints,idum,ran0)
+
+!     $Id$
+!     Platform independent random number generator from
+!     Numerical Recipies
+!     Mark Webb July 1999
+      
+      implicit none
+
+      integer j,npoints,idum(npoints),IA,IM,IQ,IR,k(npoints)
+      real ran0(npoints),AM
+
+      parameter (IA=16807, IM=2147483647, AM=1.0/IM, IQ=127773, IR=2836)
+      
+c     do j=1,npoints
+c       if (idum(j).eq.0) then
+c     	  write(6,*) 'idum=',idum
+c  write(6,*) 'ZERO seed not allowed'
+c  stop
+c       endif
+c     enddo
+
+      do j=1,npoints
+        k(j)=idum(j)/IQ
+        idum(j)=IA*(idum(j)-k(j)*IQ)-IR*k(j)
+        if (idum(j).lt.0) idum(j)=idum(j)+IM
+        ran0(j)=AM*idum(j)
+      enddo
+
+      end
+      
Index: LMDZ4/tags/LF_20080728/libf/phylmd/read_pstoke.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/read_pstoke.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/read_pstoke.F	(revision 984)
@@ -0,0 +1,486 @@
+!
+! $Header$
+!
+c
+c
+	subroutine read_pstoke(irec,
+     .   zrec,zklono,zklevo,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   fm_therm,en_therm,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+C******************************************************************************
+C  Frederic HOURDIN, Abderrahmane IDELKADI
+C Lecture des parametres physique stockes online necessaires pour
+C recalculer offline le transport de traceurs sur une grille 2x plus fine que 
+C celle online 
+C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+C******************************************************************************
+
+       USE dimphy
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+cccc#include "dimphy.h"
+	
+	  integer klono,klevo,imo,jmo
+	  parameter (imo=iim/2,jmo=(jjm+1)/2)
+	  parameter(klono=(jmo-1)*imo+2,klevo=llm)
+	  REAL phisfi(klono)
+          REAL phisfi2(imo,jmo+1),airefi2(imo,jmo+1)
+
+          REAL mfu(klono,klevo), mfd(klono,klevo)
+          REAL en_u(klono,klevo), de_u(klono,klevo)
+          REAL en_d(klono,klevo), de_d(klono,klevo)
+          REAL coefh(klono,klevo)
+           REAL fm_therm(klono,klevo),en_therm(klono,klevo)
+
+          REAL mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo)
+          REAL en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo)
+          REAL en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo)
+          REAL coefh2(imo,jmo+1,klevo)
+           REAL fm_therm2(imo,jmo+1,klevo)
+           REAL en_therm2(imo,jmo+1,klevo)
+
+          REAL pl(klevo)
+          integer irec
+          integer xid,yid,zid,tid
+          real zrec,zklono,zklevo,zim,zjm
+          integer ncrec,ncklono,ncklevo,ncim,ncjm
+
+          real airefi(klono)
+          character*20 namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def klono
+c dim de phis??
+	  
+	 
+          REAL frac_impa(klono,klevo), frac_nucl(klono,klevo)
+          REAL frac_impa2(imo,jmo+1,klevo), 
+     .     frac_nucl2(imo,jmo+1,klevo)
+          REAL pyu1(klono), pyv1(klono)
+          REAL pyu12(imo,jmo+1), pyv12(imo,jmo+1)
+          REAL ftsol(klono,nbsrf)
+          REAL psrf(klono,nbsrf) 
+	  REAL ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono)
+          REAL psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono)
+          REAL ftsol12(imo,jmo+1),ftsol22(imo,jmo+1),
+     .     ftsol32(imo,jmo+1),
+     .     ftsol42(imo,jmo+1)
+          REAL psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1),
+     .     psrf42(imo,jmo+1)
+		REAL t(klono,klevo)
+		REAL t2(imo,jmo+1,klevo)	
+	  integer ncidp
+          save ncidp
+		integer varidt
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+          integer varidend,varidded,varidch,varidfi,varidfn
+           integer varidfmth,varidenth
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+          save varidend,varidded,varidch,varidfi,varidfn
+           save varidfmth,varidenth
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+		save varidt
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+c A FAIRE: Es-il necessaire de stocke t?
+	        varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+	
+c abder (pour thermiques)
+             varidfmth=NCVID(ncidp,'fm_th',rcode)
+             print*,'ncidp,varidfmth',ncidp,varidfmth
+
+             varidenth=NCVID(ncidp,'en_th',rcode)
+             print*,'ncidp,varidenth',ncidp,varidenth
+
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,ncklevo)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zklevo=ncklevo
+            zim=ncim
+            zjm=ncjm
+	
+	    zklono=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : zklevo = ', zklevo
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : zklono = ', zklono
+
+c niveaux de pression
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,zklevo,pl)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl)
+#endif
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi)
+
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+       call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=zklevo
+      count(4)=1
+
+
+C *** Lessivage******************************************************
+c frac_impa 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa)
+
+c frac_nucl 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl)
+
+C*** Temperature ******************************************************
+c abder t
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t)
+
+C*** Flux pour le calcul de la convection TIEDTK ***********************
+c mfu
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d)
+
+C **** Coeffecient du mellange turbulent**********************************
+c coefh 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+       call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh)
+
+C*** Flux ascendant et entrant pour les Thermiques************************
+cabder thermiques
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,count,fm_therm2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfmth,start,count,fm_therm2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,fm_therm2,fm_therm)
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,count,en_therm2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenth,start,count,en_therm2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_therm2,en_therm)
+
+C*** Vitesses aux sol ******************************************************
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+c pyu1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1)
+
+c pyv1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1)
+
+C*** Temperature au sol ********************************************
+c ftsol1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1)
+
+c ftsol2
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2)
+
+c ftsol3
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4)
+
+C*** Nature du sol **************************************************
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4)
+	
+          do i = 1,klono
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/read_pstoke0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/read_pstoke0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/read_pstoke0.F	(revision 984)
@@ -0,0 +1,511 @@
+!
+! $Header$
+!
+c
+c
+	subroutine read_pstoke0(irec,
+     .   zrec,zkon,zkev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   fm_therm,en_therm,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+C******************************************************************************
+C  Frederic HOURDIN, Abderrahmane IDELKADI
+C Lecture des parametres physique stockes online necessaires pour
+C recalculer offline le transport des traceurs sur la meme grille que online
+C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+C******************************************************************************
+
+
+       USE dimphy
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+cccc#include "dimphy.h"
+	  
+	  integer kon,kev,zkon,zkev
+	  parameter(kon=iim*(jjm-1)+2,kev=llm)
+	  REAL phisfi(kon)
+          REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
+
+          REAL mfu(kon,kev), mfd(kon,kev)
+          REAL en_u(kon,kev), de_u(kon,kev)
+          REAL en_d(kon,kev), de_d(kon,kev)
+          REAL coefh(kon,kev)
+
+c abd 25 11 02
+c Thermiques
+	 REAL fm_therm(kon,kev),en_therm(kon,kev)
+		REAL t(kon,kev)
+
+          REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
+          REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
+          REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
+          REAL coefh2(iim,jjm+1,kev)
+		REAL t2(iim,jjm+1,kev)
+c Thermiques
+	 REAL fm_therm2(iim,jjm+1,kev)
+         REAL en_therm2(iim,jjm+1,kev)       
+
+          REAL pl(kev)
+          integer irec
+          integer xid,yid,zid,tid
+          integer zrec,zim,zjm
+          integer ncrec,nckon,nckev,ncim,ncjm
+
+          real airefi(kon)
+          character*20 namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def kon
+c dim de phis??
+
+          REAL frac_impa(kon,kev), frac_nucl(kon,kev)
+          REAL frac_impa2(iim,jjm+1,kev), 
+     .     frac_nucl2(iim,jjm+1,kev)
+          REAL pyu1(kon), pyv1(kon)
+          REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1)
+          REAL ftsol(kon,nbsrf)
+          REAL psrf(kon,nbsrf) 
+	  REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
+          REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
+          REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
+     .     ftsol32(iim,jjm+1),
+     .     ftsol42(iim,jjm+1)
+          REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
+     .     psrf42(iim,jjm+1)
+	
+	  integer ncidp
+          save ncidp
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+		integer varidt
+          integer varidend,varidded,varidch,varidfi,varidfn
+c therm
+	  integer varidfmth,varidenth
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+		save varidt
+          save varidend,varidded,varidch,varidfi,varidfn
+c therm
+	   save varidfmth,varidenth
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+                varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+
+c Thermiques
+            varidfmth=NCVID(ncidp,'fm_th',rcode)
+            print*,'ncidp,varidfmth',ncidp,varidfmth
+
+            varidenth=NCVID(ncidp,'en_th',rcode)
+            print*,'ncidp,varidenth',ncidp,varidenth
+	
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,nckev)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zkev=nckev
+            zim=ncim
+            zjm=ncjm
+	
+	    zkon=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : kev = ', zkev
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : kon = ', zkon
+
+c niveaux de pression
+
+            status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c 
+C**** Geopotentiel au sol ***************************************
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
+
+C**** Aires des mails aux sol ************************************
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=kev
+      count(4)=1
+
+C**** Temperature ********************************************
+cA FAIRE : Es-ce necessaire ?
+
+c abder t
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
+
+C**** Flux pour la convection (Tiedtk) ********************************************
+c mfu
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
+
+C**** Coefficient de mellange turbulent *******************************************
+c coefh 
+	print*,'LECTURE de coefh a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
+c      call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ   ')
+c      call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ   ')
+
+C**** Flux ascendants et entrant dans le thermique **********************************
+cThermiques
+       print*,'LECTURE de fm_therm a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,
+     .                         count,fm_therm2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidfmth,start,
+     .                         count,fm_therm2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm)
+       print*,'LECTURE de en_therm a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,
+     .                          count,en_therm2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidenth,start,
+     .                          count,en_therm2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm)
+
+C**** Coefficients de lessivage *******************************************
+c frac_impa
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
+
+c frac_nucl
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
+
+C**** Vents aux sol ********************************************
+
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+
+c pyu1
+	print*,'LECTURE de yu1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
+
+c pyv1
+        print*,'LECTURE de yv1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
+
+C**** Temerature au sol ********************************************
+c ftsol1
+        print*,'LECTURE de ftsol1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
+
+c ftsol2
+        print*,'LECTURE de ftsol2 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
+
+c ftsol3
+	 print*,'LECTURE de ftsol3 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
+
+C**** Nature sol ********************************************
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
+	
+          do i = 1,kon
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+c test abderr
+c	print*,'Dans read_pstoke psrf3 =',psrf3(i),i
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/readsulfate.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/readsulfate.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/readsulfate.F	(revision 984)
@@ -0,0 +1,641 @@
+!
+! $Header$
+!
+      SUBROUTINE readsulfate (r_day, first, sulfate_p)
+      USE dimphy, ONLY : klev
+      USE mod_grid_phy_lmdz, klon=>klon_glo
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+      
+c Content: 
+c --------
+c This routine reads in monthly mean values of sulfate aerosols and 
+c returns a linearly interpolated dayly-mean field.      
+c 
+c
+c Author:
+c -------
+c Johannes Quaas (quaas@lmd.jussieu.fr) 
+c 26/04/01
+c
+c Modifications:
+c --------------
+c 21/06/01: Make integrations of more than one year possible ;-)     
+c           ATTENTION!! runs are supposed to start with Jan, 1. 1930
+c                       (rday=1)      
+c
+c 27/06/01: Correction: The model always has 360 days per year!
+c 27/06/01: SO4 concentration rather than mixing ratio      
+c 27/06/01: 10yr-mean-values to interpolate     
+c 20/08/01: Correct the error through integer-values in interpolations      
+c 21/08/01: Introduce flag to read in just one decade
+c      
+c Include-files:
+c --------------     
+#include "YOMCST.h"
+#include "chem.h"      
+#include "dimensions.h"      
+cym#include "dimphy.h"      
+#include "temps.h"      
+c 
+c Input:
+c ------
+      REAL  r_day                   ! Day of integration
+      LOGICAL first                 ! First timestep 
+                                    ! (and therefore initialization necessary)
+c      
+c Output:      
+c -------     
+      REAL  sulfate_p(klon_omp,klev)
+      REAL  sulfate (klon, klev)  ! Mass of sulfate (monthly mean data, 
+                                  !  from file) [ug SO4/m3]
+c      
+c Local Variables:
+c ----------------      
+      INTEGER i, ig, k, it
+      INTEGER j, iday, ny, iyr, iyr1, iyr2
+      parameter (ny=jjm+1)
+      
+CJLD      INTEGER idec1, idec2 ! The two decadal data read ini
+      CHARACTER*4 cyear
+      
+      INTEGER im, day1, day2, im2
+      REAL so4_1(iim, jjm+1, klev, 12)
+      REAL so4_2(iim, jjm+1, klev, 12)   ! The sulfate distributions
+      
+      REAL, allocatable,save :: so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: so4_out(:, :)
+c$OMP THREADPRIVATE(so4,so4_out)
+      
+      LOGICAL lnewday 
+      LOGICAL lonlyone
+      PARAMETER (lonlyone=.FALSE.)
+      logical,save :: first2=.true.
+c$OMP THREADPRIVATE(first2)
+
+c$OMP MASTER
+      if (first2) then
+     
+        allocate( so4(klon, klev, 12) )
+        allocate( so4_out(klon, klev))
+        first2=.false.
+	
+      endif
+
+      if (is_mpi_root) then
+            
+      iday = INT(r_day) 
+      
+      ! Get the year of the run
+      iyr  = iday/360
+      
+      ! Get the day of the actual year:
+      iday = iday-iyr*360
+      
+      ! 0.02 is about 0.5/24, namly less than half an hour
+      lnewday = (r_day-FLOAT(iday).LT.0.02)
+      
+! ---------------------------------------------
+! All has to be done only, if a new day begins!       
+! ---------------------------------------------
+
+      IF (lnewday.OR.first) THEN
+         
+      im = iday/30 +1 ! the actual month
+      ! annee_ref is the initial year (defined in temps.h)
+      iyr = iyr + annee_ref
+      
+      ! Do I have to read new data? (Is this the first day of a year?)
+      IF (first.OR.iday.EQ.1.) THEN 
+      ! Initialize values
+      DO it=1,12
+      DO k=1,klev
+         DO i=1,klon
+            so4(i,k,it)=0.
+         ENDDO
+      ENDDO
+      ENDDO
+
+
+      IF (iyr .lt. 1850) THEN
+         cyear='.nat'
+         WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+         CALL getso4fromfile(cyear, so4_1)
+      ELSE IF (iyr .ge. 2100) THEN
+         cyear='2100'
+         WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+         CALL getso4fromfile(cyear, so4_1)
+      ELSE
+
+      	! Read in data:
+      ! a) from actual 10-yr-period
+
+      IF (iyr.LT.1900) THEN
+         iyr1 = 1850
+         iyr2 = 1900
+      ELSE IF (iyr.ge.1900.and.iyr.lt.1920) THEN
+         iyr1 = 1900
+         iyr2 = 1920
+      ELSE 
+         iyr1 = INT(iyr/10)*10
+         iyr2 = INT(1+iyr/10)*10
+      ENDIF
+      WRITE(cyear,'(I4)') iyr1
+      WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+      CALL getso4fromfile(cyear, so4_1)
+
+      
+      ! If to read two decades:
+      IF (.NOT.lonlyone) THEN
+         
+      ! b) from the next following one
+      WRITE(cyear,'(I4)') iyr2
+      WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+      CALL getso4fromfile(cyear, so4_2)
+
+      ENDIF
+ 
+      ! Interpolate linarily to the actual year:
+      DO it=1,12
+         DO k=1,klev
+            DO j=1,jjm
+               DO i=1,iim
+                  so4_1(i,j,k,it)=so4_1(i,j,k,it)
+     .                 - FLOAT(iyr-iyr1)/FLOAT(iyr2-iyr1)
+     .                 * (so4_1(i,j,k,it) - so4_2(i,j,k,it))
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDDO                           
+      
+      ENDIF !lonlyone
+      
+      ! Transform the horizontal 2D-field into the physics-field
+      ! (Also the levels and the latitudes have to be inversed)
+      
+      DO it=1,12
+      DO k=1, klev         
+         ! a) at the poles, use the zonal mean:
+         DO i=1,iim
+            ! North pole
+            so4(1,k,it)=so4(1,k,it)+so4_1(i,jjm+1,klev+1-k,it)
+            ! South pole
+            so4(klon,k,it)=so4(klon,k,it)+so4_1(i,1,klev+1-k,it)
+         ENDDO
+         so4(1,k,it)=so4(1,k,it)/FLOAT(iim)
+         so4(klon,k,it)=so4(klon,k,it)/FLOAT(iim)
+      
+         ! b) the values between the poles:
+         ig=1
+         DO j=2,jjm
+            DO i=1,iim
+               ig=ig+1
+               if (ig.gt.klon) write (*,*) 'shit'
+               so4(ig,k,it) = so4_1(i,jjm+1+1-j,klev+1-k,it)
+            ENDDO
+         ENDDO
+         IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)'
+      ENDDO ! Loop over k (vertical)
+      ENDDO ! Loop over it (months)
+               
+
+      ENDIF ! Had to read new data?
+      
+      
+      ! Interpolate to actual day:
+      IF (iday.LT.im*30-15) THEN         
+         ! in the first half of the month use month before and actual month
+         im2=im-1
+         day2 = im2*30-15
+         day1 = im2*30+15
+         IF (im2.LE.0) THEN 
+            ! the month is january, thus the month before december
+            im2=12
+         ENDIF
+         DO k=1,klev
+            DO i=1,klon
+               sulfate(i,k) = so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (so4(i,k,im2) - so4(i,k,im))
+               IF (sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (so4(i,k,im2) - so4(i,k,im).LT.0.)
+     . write(*,*) 'so4(i,k,im2) - so4(i,k,im)',
+     . so4(i,k,im2) - so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ELSE 
+         ! the second half of the month
+         im2=im+1
+         IF (im2.GT.12) THEN
+            ! the month is december, the following thus january
+            im2=1
+         ENDIF
+         day2 = im*30-15
+         day1 = im*30+15
+         DO k=1,klev
+            DO i=1,klon
+               sulfate(i,k) = so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (so4(i,k,im2) - so4(i,k,im))
+               IF (sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (so4(i,k,im2) - so4(i,k,im).LT.0.)
+     . write(*,*) 'so4(i,k,im2) - so4(i,k,im)',
+     . so4(i,k,im2) - so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+
+      
+CJLD      ! The sulfate concentration [molec cm-3] is read in. 
+CJLD      ! Convert it into mass [ug SO4/m3]
+CJLD      ! masse_so4 in [g/mol], n_avogadro in [molec/mol]
+      ! The sulfate mass [ug SO4/m3] is read in. 
+      DO k=1,klev
+         DO i=1,klon
+CJLD            sulfate(i,k) = sulfate(i,k)*masse_so4
+CJLD     .           /n_avogadro*1.e+12
+            so4_out(i,k) = sulfate(i,k)
+            IF (so4_out(i,k).LT.0) 
+     .          stop 'WAS SOLL DER SCHEISS ? '
+         ENDDO
+      ENDDO
+      ELSE ! if no new day, use old data:
+      DO k=1,klev
+         DO i=1,klon
+            sulfate(i,k) = so4_out(i,k)
+            IF (so4_out(i,k).LT.0) 
+     .          stop 'WAS SOLL DER SCHEISS ? '
+         ENDDO
+      ENDDO
+         
+
+      ENDIF ! Did I have to do anything (was it a new day?)
+
+      endif   ! phy_rank==0
+      
+c$OMP END MASTER
+      call Scatter(sulfate,sulfate_p)            
+
+      RETURN
+      END
+
+      
+      
+      
+      
+c-----------------------------------------------------------------------------
+c Read in /calculate pre-industrial values of sulfate      
+c-----------------------------------------------------------------------------
+      
+      SUBROUTINE readsulfate_preind (r_day, first, pi_sulfate_p)
+      USE dimphy, ONLY : klev
+      USE mod_grid_phy_lmdz, klon=>klon_glo
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+      
+c Content: 
+c --------
+c This routine reads in monthly mean values of sulfate aerosols and 
+c returns a linearly interpolated dayly-mean field.      
+c 
+c It does so for the preindustriel values of the sulfate, to a large part
+c analogous to the routine readsulfate above.      
+c
+c Only Pb: Variables must be saved and don t have to be overwritten!
+c      
+c Author:
+c -------
+c Johannes Quaas (quaas@lmd.jussieu.fr) 
+c 26/06/01
+c
+c Modifications:
+c --------------
+c see above 
+c      
+c Include-files:
+c --------------     
+#include "YOMCST.h"
+#include "chem.h"      
+#include "dimensions.h"      
+#include "temps.h"      
+c 
+c Input:
+c ------
+      REAL  r_day                   ! Day of integration
+      LOGICAL first                 ! First timestep 
+                                    ! (and therefore initialization necessary)
+c      
+c Output:      
+c -------     
+      REAL  pi_sulfate_p (klon_omp, klev)  
+                                 
+      REAL  pi_sulfate (klon, klev)  ! Number conc. sulfate (monthly mean data, 
+                                  !  from fil
+c      
+c Local Variables:
+c ----------------      
+      INTEGER i, ig, k, it
+      INTEGER j, iday, ny, iyr
+      parameter (ny=jjm+1)
+      
+      INTEGER im, day1, day2, im2
+      REAL pi_so4_1(iim, jjm+1, klev, 12)
+
+      REAL, allocatable,save :: pi_so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: pi_so4_out(:, :)
+c$OMP THREADPRIVATE(pi_so4,pi_so4_out)            
+      
+      CHARACTER*4 cyear
+      LOGICAL lnewday
+      logical,save :: first2=.true.
+c$OMP THREADPRIVATE(first2)
+
+c$OMP MASTER
+      if (first2) then
+     
+        allocate( pi_so4(klon, klev, 12) )
+        allocate( pi_so4_out(klon, klev))
+        first2=.false.
+	
+      endif
+
+      if (is_mpi_root) then
+    
+      
+
+      iday = INT(r_day) 
+      
+      ! Get the year of the run
+      iyr  = iday/360
+      
+      ! Get the day of the actual year:
+      iday = iday-iyr*360
+      
+      ! 0.02 is about 0.5/24, namly less than half an hour
+      lnewday = (r_day-FLOAT(iday).LT.0.02)
+      
+! ---------------------------------------------
+! All has to be done only, if a new day begins!       
+! ---------------------------------------------
+
+      IF (lnewday.OR.first) THEN
+         
+      im = iday/30 +1 ! the actual month
+      
+      ! annee_ref is the initial year (defined in temps.h)
+      iyr = iyr + annee_ref      
+      
+      
+      IF (first) THEN
+         cyear='.nat'
+         CALL getso4fromfile(cyear,pi_so4_1)
+
+               ! Transform the horizontal 2D-field into the physics-field
+               ! (Also the levels and the latitudes have to be inversed)
+
+         ! Initialize field
+         DO it=1,12
+            DO k=1,klev
+               DO i=1,klon
+                  pi_so4(i,k,it)=0.
+               ENDDO
+            ENDDO
+         ENDDO
+         
+         write (*,*) 'preind: finished reading', FLOAT(iim)
+      DO it=1,12
+      DO k=1, klev         
+         ! a) at the poles, use the zonal mean:
+         DO i=1,iim
+            ! North pole
+            pi_so4(1,k,it)=pi_so4(1,k,it)+pi_so4_1(i,jjm+1,klev+1-k,it)
+            ! South pole
+           pi_so4(klon,k,it)=pi_so4(klon,k,it)+pi_so4_1(i,1,klev+1-k,it)
+         ENDDO
+         pi_so4(1,k,it)=pi_so4(1,k,it)/FLOAT(iim)
+         pi_so4(klon,k,it)=pi_so4(klon,k,it)/FLOAT(iim)
+      
+         ! b) the values between the poles:
+         ig=1
+         DO j=2,jjm
+            DO i=1,iim
+               ig=ig+1
+               if (ig.gt.klon) write (*,*) 'shit'
+               pi_so4(ig,k,it) = pi_so4_1(i,jjm+1+1-j,klev+1-k,it)
+            ENDDO
+         ENDDO
+         IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)'
+      ENDDO ! Loop over k (vertical)
+      ENDDO ! Loop over it (months)
+
+      ENDIF                     ! Had to read new data?
+      
+      
+      ! Interpolate to actual day:
+      IF (iday.LT.im*30-15) THEN         
+         ! in the first half of the month use month before and actual month
+         im2=im-1
+         day1 = im2*30+15
+         day2 = im2*30-15
+         IF (im2.LE.0) THEN 
+            ! the month is january, thus the month before december
+            im2=12
+         ENDIF
+         DO k=1,klev
+            DO i=1,klon
+               pi_sulfate(i,k) = pi_so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (pi_so4(i,k,im2) - pi_so4(i,k,im))
+               IF (pi_sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.)
+     . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)',
+     . pi_so4(i,k,im2) - pi_so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'pi_sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ELSE 
+         ! the second half of the month
+         im2=im+1
+         day1 = im*30+15
+         IF (im2.GT.12) THEN
+            ! the month is december, the following thus january
+            im2=1
+         ENDIF
+         day2 = im*30-15
+         
+         DO k=1,klev
+            DO i=1,klon
+               pi_sulfate(i,k) = pi_so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (pi_so4(i,k,im2) - pi_so4(i,k,im))
+               IF (pi_sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.)
+     . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)',
+     . pi_so4(i,k,im2) - pi_so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'pi_sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+
+      
+CJLD      ! The sulfate concentration [molec cm-3] is read in. 
+CJLD      ! Convert it into mass [ug SO4/m3]
+CJLD      ! masse_so4 in [g/mol], n_avogadro in [molec/mol]
+      DO k=1,klev
+         DO i=1,klon
+CJLD            pi_sulfate(i,k) = pi_sulfate(i,k)*masse_so4
+CJLD     .           /n_avogadro*1.e+12
+            pi_so4_out(i,k) = pi_sulfate(i,k)
+         ENDDO
+      ENDDO
+      
+      ELSE ! If no new day, use old data:
+      DO k=1,klev
+         DO i=1,klon
+            pi_sulfate(i,k) = pi_so4_out(i,k)            
+         ENDDO
+      ENDDO
+         
+
+      ENDIF ! Was this the beginning of a new day?
+
+      endif   ! is_mpi_root==0
+      
+c$OMP END MASTER
+      call Scatter(pi_sulfate,pi_sulfate_p)            
+
+      RETURN
+      END
+
+      
+      
+      
+      
+      
+      
+      
+      
+      
+c-----------------------------------------------------------------------------
+c Routine for reading SO4 data from files
+c-----------------------------------------------------------------------------
+            
+
+      SUBROUTINE getso4fromfile (cyr, so4)
+      use dimphy
+#include "netcdf.inc"
+#include "dimensions.h"      
+cccc#include "dimphy.h"
+      CHARACTER*15 fname
+      CHARACTER*4 cyr
+      
+      CHARACTER*6 cvar
+      INTEGER START(3), COUNT(3)
+      INTEGER  STATUS, NCID, VARID
+      INTEGER imth, i, j, k, ny
+      PARAMETER (ny=jjm+1)
+      
+            
+      REAL so4mth(iim, ny, klev)
+      REAL so4(iim, ny, klev, 12)
+
+ 
+      fname = 'so4.run'//cyr//'.cdf'
+
+      write (*,*) 'reading ', fname
+      STATUS = NF_OPEN (fname, NF_NOWRITE, NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in open ',status
+            
+      DO imth=1, 12
+         IF (imth.eq.1) THEN
+            cvar='SO4JAN'
+         ELSEIF (imth.eq.2) THEN
+            cvar='SO4FEB'
+         ELSEIF (imth.eq.3) THEN
+            cvar='SO4MAR'
+         ELSEIF (imth.eq.4) THEN
+            cvar='SO4APR'
+         ELSEIF (imth.eq.5) THEN
+            cvar='SO4MAY'
+         ELSEIF (imth.eq.6) THEN
+            cvar='SO4JUN'
+         ELSEIF (imth.eq.7) THEN
+            cvar='SO4JUL'
+         ELSEIF (imth.eq.8) THEN
+            cvar='SO4AUG'
+         ELSEIF (imth.eq.9) THEN
+            cvar='SO4SEP'
+         ELSEIF (imth.eq.10) THEN
+            cvar='SO4OCT'
+         ELSEIF (imth.eq.11) THEN
+            cvar='SO4NOV'
+         ELSEIF (imth.eq.12) THEN
+            cvar='SO4DEC'
+         ENDIF
+         start(1)=1
+         start(2)=1
+         start(3)=1
+         count(1)=iim
+         count(2)=ny
+         count(3)=klev
+c         write(*,*) 'here i am'
+         STATUS = NF_INQ_VARID (NCID, cvar, VARID)
+         write (*,*) ncid,imth,cvar, varid
+
+         IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read ',status      
+
+#ifdef NC_DOUBLE
+         status = NF_GET_VARA_DOUBLE(NCID, VARID, START, COUNT, so4mth)
+#else
+         status = NF_GET_VARA_REAL(NCID, VARID, START, COUNT, so4mth)
+#endif
+         IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read data',status
+         
+         DO k=1,klev
+            DO j=1,jjm+1
+               DO i=1,iim
+                  IF (so4mth(i,j,k).LT.0.) then
+                     write(*,*) 'this is shit'
+                     write(*,*) 'so4(',i,j,k,') =',so4mth(i,j,k)
+                  endif
+                  so4(i,j,k,imth)=so4mth(i,j,k)
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDDO
+      
+      STATUS = NF_CLOSE(NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in closing file',status
+
+
+      END ! subroutine getso4fromfile
+      
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/regdim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/regdim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/regdim.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      INTEGER i1_deb, i1_fin
+      INTEGER i2_deb, i2_fin
+ccc      PARAMETER (i1_deb=21, i1_fin=40)
+ccc      PARAMETER (i2_deb=41, i2_fin=44)
+cccc      PARAMETER (i1_deb=47, i1_fin=77)
+cccc      PARAMETER (i2_deb=78, i2_fin=79)
+      PARAMETER (i1_deb=16, i1_fin=30)
+      PARAMETER (i2_deb=31, i2_fin=33)
+c
+      INTEGER j_deb, j_fin
+ccc      PARAMETER (j_deb=29, j_fin=61)
+cccc      PARAMETER (j_deb=21, j_fin=51)
+      PARAMETER (j_deb=18, j_fin=39)
Index: LMDZ4/tags/LF_20080728/libf/phylmd/screenc.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/screenc.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/screenc.F90	(revision 984)
@@ -0,0 +1,84 @@
+!
+! $Header$
+!
+      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, rugos, psol, &
+                         ustar, testar, qstar, okri, ri1, &
+                         pref, delu, delte, delq)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
+!
+      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
+!-----------------------------------------------------------------------
+      include "YOMCST.h"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+      CALL coefcdrag (klon, knon, nsrf, zxli, &
+                    speed, temp, q_zref, gref, &
+                    psol, ts, qsurf, rugos, &
+                    okri, ri1, &
+                    cdram, cdrah, cdran, zri1, &
+                    pref)
+!
+      DO i = 1, knon
+        delu(i) = ustar(i)/sqrt(cdram(i))
+        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
+                   cdrah(i)
+        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
+                  cdrah(i)
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screenc
Index: LMDZ4/tags/LF_20080728/libf/phylmd/screenp.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/screenp.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/screenp.F90	(revision 984)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE screenp(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, lmon, &
+     &                   ustar, testar, qstar, zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! lmon----input-R- longueur de Monin-Obukov
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+        IF (lmon(i).GE.0.) THEN
+!
+! STABLE CASE
+!
+          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0                        &
+     &                      .AND. rugos(i).LE.1.0) THEN
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 *(zref - rugos(i))/lmon(i)))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) + &
+                       min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+            delq(i) = (qstar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+          ELSE
+            delu(i)  = 0.1 * speed(i)
+            delte(i) = 0.1 * (tair(i) - ts(i) )
+            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ELSE  
+!
+! UNSTABLE CASE
+!
+          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
+            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
+            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) & 
+                      - 2.*log(0.5*(1. + xtmp)) &
+                      + 2.*log(0.5*(1. + xtmp0)) &
+                      - log(0.5*(1. + xtmp*xtmp)) &
+                      + log(0.5*(1. + xtmp0*xtmp0)) &
+                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+            delq(i)  = (qstar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+          ELSE
+            delu(i)  = 0.5 * speed(i)
+            delte(i) = 0.5 * (tair(i) - ts(i) )
+            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenp
Index: LMDZ4/tags/LF_20080728/libf/phylmd/soil.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/soil.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/soil.F	(revision 984)
@@ -0,0 +1,269 @@
+!
+! $Header$
+!
+      SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, ptsoil,
+     s          pcapcal, pfluxgrd)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  Frederic Hourdin     30/01/92
+c   -------
+c
+c   objet:  computation of : the soil temperature evolution
+c   ------                   the surfacic heat capacity "Capcal"
+c                            the surface conduction flux pcapcal
+c
+c
+c   Method: implicit time integration
+c   -------
+c   Consecutive ground temperatures are related by:
+c           T(k+1) = C(k) + D(k)*T(k)  (1)
+c   the coefficients C and D are computed at the t-dt time-step.
+c   Routine structure:
+c   1)new temperatures are computed  using (1)
+c   2)C and D coefficients are computed from the new temperature
+c     profile for the t+dt time-step
+c   3)the coefficients A and B are computed where the diffusive
+c     fluxes at the t+dt time-step is given by
+c            Fdiff = A + B Ts(t+dt)
+c     or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
+c            with F0 = A + B (Ts(t))
+c                 Capcal = B*dt
+c           
+c   Interface:
+c   ----------
+c
+c   Arguments:
+c   ----------
+c   ptimestep            physical timestep (s)
+c   indice               sub-surface index
+c   snow(klon,nbsrf)     snow
+c   ptsrf(klon)          surface temperature at time-step t (K)
+c   ptsoil(klon,nsoilmx) temperature inside the ground (K)
+c   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
+c   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
+c   
+c=======================================================================
+c   declarations:
+c   -------------
+
+cym#include "dimensions.h"
+#include "YOMCST.h"
+cym#include "dimphy.h"
+#include "dimsoil.h"
+#include "indicesol.h"
+#include "comsoil.h"
+
+c-----------------------------------------------------------------------
+c  arguments
+c  ---------
+
+      REAL ptimestep
+      INTEGER indice, knon
+      REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon)
+      REAL pcapcal(klon),pfluxgrd(klon)
+
+c-----------------------------------------------------------------------
+c  local arrays
+c  ------------
+
+      INTEGER ig,jk
+c@$$      REAL zdz2(nsoilmx),z1(klon)
+      REAL zdz2(nsoilmx),z1(klon,nbsrf)
+      REAL,SAVE :: min_period,dalph_soil
+c$OMP THREADPRIVATE( min_period,dalph_soil)     
+      REAL ztherm_i(klon)
+
+c   local saved variables:
+c   ----------------------
+      REAL dz1(nsoilmx),dz2(nsoilmx)
+c@$$          REAL zc(klon,nsoilmx),zd(klon,nsoilmx)
+cym      REAL zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf)
+      REAL,ALLOCATABLE,SAVE ::  zc(:,:,:),zd(:,:,:)
+c$OMP THREADPRIVATE(zc,zd)
+      REAL lambda
+cym      SAVE dz1,dz2,zc,zd,lambda
+      SAVE dz1,dz2,lambda
+c$OMP THREADPRIVATE(dz1,dz2,lambda)
+      LOGICAL firstcall, firstsurf(nbsrf)
+      SAVE firstcall, firstsurf
+c$OMP THREADPRIVATE(firstcall, firstsurf)
+      DATA firstcall/.true./
+      DATA firstsurf/.TRUE.,.TRUE.,.TRUE.,.TRUE./
+
+      LOGICAL,SAVE :: First=.true.
+c$OMP THREADPRIVATE(First)
+c-----------------------------------------------------------------------
+c   Depthts:
+c   --------
+
+      REAL fz,rk,fz1,rk1,rk2
+      fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
+      pfluxgrd(:) = 0.
+c   calcul de l'inertie thermique a partir de la variable rnat.
+c   on initialise a inertie_ice meme au-dessus d'un point de mer au cas 
+c   ou le point de mer devienne point de glace au pas suivant
+c   on corrige si on a un point de terre avec ou sans glace
+c
+      IF (first) THEN
+        allocate(zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf))
+	first=.false.
+      ENDIF
+      
+      IF (indice.EQ.is_sic) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = inertie_ice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = inertie_sno
+         ENDDO
+      ELSE IF (indice.EQ.is_lic) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = inertie_ice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = inertie_sno
+         ENDDO
+      ELSE IF (indice.EQ.is_ter) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = inertie_sol
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = inertie_sno
+         ENDDO
+      ELSE IF (indice.EQ.is_oce) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = inertie_ice
+         ENDDO
+      ELSE
+         PRINT*, "valeur d indice non prevue", indice
+         CALL abort
+      ENDIF
+
+
+c@$$      IF (firstcall) THEN
+      IF (firstsurf(indice)) THEN 
+
+c-----------------------------------------------------------------------
+c   ground levels 
+c   grnd=z/l where l is the skin depth of the diurnal cycle:
+c   --------------------------------------------------------
+
+         min_period=1800. ! en secondes
+         dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
+c$OMP MASTER
+         IF (is_mpi_root) THEN
+         OPEN(99,file='soil.def',status='old',form='formatted',err=9999)
+         READ(99,*) min_period
+         READ(99,*) dalph_soil
+         PRINT*,'Discretization for the soil model'
+         PRINT*,'First level e-folding depth',min_period,
+     s   '   dalph',dalph_soil
+         CLOSE(99)
+9999     CONTINUE
+         ENDIF  ! is_mpi_root
+c$OMP END MASTER
+         CALL bcast(min_period)
+	 CALL bcast(dalph_soil)
+
+c   la premiere couche represente un dixieme de cycle diurne
+         fz1=sqrt(min_period/3.14)
+
+         DO jk=1,nsoilmx
+            rk1=jk
+            rk2=jk-1
+            dz2(jk)=fz(rk1)-fz(rk2)
+         ENDDO
+         DO jk=1,nsoilmx-1
+            rk1=jk+.5
+            rk2=jk-.5
+            dz1(jk)=1./(fz(rk1)-fz(rk2))
+         ENDDO
+         lambda=fz(.5)*dz1(1)
+         PRINT*,'full layers, intermediate layers (seconds)'
+         DO jk=1,nsoilmx
+            rk=jk
+            rk1=jk+.5
+            rk2=jk-.5
+            PRINT *,'fz=',
+     .               fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
+         ENDDO
+C PB
+         firstsurf(indice) = .FALSE. 
+c@$$         firstcall =.false.
+
+c   Initialisations:
+c   ----------------
+
+      ELSE   !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the soil temperatures using the Cgrd and Dgrd
+c  coefficient computed at the previous time-step:
+c  -----------------------------------------------
+
+c    surface temperature
+         DO ig=1,knon
+            ptsoil(ig,1)=(lambda*zc(ig,1,indice)+ptsrf(ig))/
+     s      (lambda*(1.-zd(ig,1,indice))+1.)
+         ENDDO
+
+c   other temperatures
+         DO jk=1,nsoilmx-1
+            DO ig=1,knon
+               ptsoil(ig,jk+1)=zc(ig,jk,indice)+zd(ig,jk,indice)
+     $            *ptsoil(ig,jk)
+            ENDDO
+         ENDDO
+
+      ENDIF !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the Cgrd and Dgrd coefficient for the next step:
+c   ---------------------------------------------------------------
+
+c@$$  PB ajout pour cas glace de mer
+      IF (indice .EQ. is_sic) THEN
+          DO ig = 1 , knon
+            ptsoil(ig,nsoilmx) = RTT - 1.8
+          END DO 
+      ENDIF 
+
+      DO jk=1,nsoilmx
+         zdz2(jk)=dz2(jk)/ptimestep
+      ENDDO
+
+      DO ig=1,knon
+         z1(ig,indice)=zdz2(nsoilmx)+dz1(nsoilmx-1)
+         zc(ig,nsoilmx-1,indice)=
+     $       zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig,indice)
+         zd(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1(ig,indice)
+      ENDDO
+
+      DO jk=nsoilmx-1,2,-1
+         DO ig=1,knon
+            z1(ig,indice)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk)
+     $         *(1.-zd(ig,jk,indice)))
+            zc(ig,jk-1,indice)=
+     s      (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk,indice))
+     $          *z1(ig,indice)
+            zd(ig,jk-1,indice)=dz1(jk-1)*z1(ig,indice)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   computation of the surface diffusive flux from ground and
+c   calorific capacity of the ground:
+c   ---------------------------------
+
+      DO ig=1,knon
+         pfluxgrd(ig)=ztherm_i(ig)*dz1(1)*
+     s   (zc(ig,1,indice)+(zd(ig,1,indice)-1.)*ptsoil(ig,1))
+         pcapcal(ig)=ztherm_i(ig)*
+     s   (dz2(1)+ptimestep*(1.-zd(ig,1,indice))*dz1(1))
+         z1(ig,indice)=lambda*(1.-zd(ig,1,indice))+1.
+         pcapcal(ig)=pcapcal(ig)/z1(ig,indice)
+         pfluxgrd(ig) = pfluxgrd(ig)
+     s   + pcapcal(ig) * (ptsoil(ig,1) * z1(ig,indice)
+     $       - lambda * zc(ig,1,indice)
+     $       - ptsrf(ig))
+     s   /ptimestep
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/stdlevvar.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/stdlevvar.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/stdlevvar.F90	(revision 984)
@@ -0,0 +1,278 @@
+!
+! $Header$
+!
+      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, rugos, psol, pat1, &
+                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar)
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!
+!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
+!
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_10m--output-R- vitesse du vent a 10m
+!AM
+! t_10m--output-R- temperature de l'air a 10m
+! q_10m--output-R- humidite specifique a 10m
+! ustar--output-R- u*
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
+      REAL, dimension(klon), intent(in) :: qsurf, rugos
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
+      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
+!-------------------------------------------------------------------------
+      include "YOMCST.h"
+!IM PLUS
+      include "YOETHF.h"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+!     INTEGER, parameter :: niter=6, ncon=niter-1
+      INTEGER, parameter :: niter=2, ncon=niter-1
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: zri1, cdran
+      REAL, dimension(klon) :: cdram, cdrah
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      REAL, dimension(klon) :: testar, qstar
+      REAL, dimension(klon) :: zdte, zdq   
+! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
+      DOUBLE PRECISION, dimension(klon) :: lmon
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: temp, pref
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+!convertgence
+      REAL, dimension(klon) :: te_zref_con, q_zref_con
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr
+!     REAL, dimension(klon) :: conv_te, conv_q
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+       speed(i)=SQRT(u1(i)**2+v1(i)**2)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+      CALL coefcdrag(klon, knon, nsrf, zxli, &
+ &                   speed, t1, q1, z1, psol, &
+ &                   ts1, qsurf, rugos, okri, ri1,  &         
+ &                   cdram, cdrah, cdran, zri1, pref)            
+!
+!---------Star variables----------------------------------------------------
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
+        zdte(i) = tpot(i) - ts1(i)
+        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
+!
+!
+!IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
+        zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
+!
+        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
+        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
+        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
+ &                (RKAR * RG * testar(i))
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+        q_zref_p(i) = q_zref(i)
+!       te_zref_p(i) = te_zref(i)
+        temp_p(i) = temp(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &           
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq) 
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i) 
+!
+! return to normal temperature
+!
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+!
+!IM +++
+!         IF(temp(i).GT.350.) THEN
+!           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
+!         ENDIF
+!IM ---
+!
+        IF(n.EQ.ncon) THEN
+          te_zref_con(i) = te_zref(i)
+          q_zref_con(i) = q_zref(i)
+        ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
+!
+!       DO i = 1, knon
+!         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
+!         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
+!IM +++
+!         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
+!           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
+!           q_zref_con(i),q_zref(i),conv_q(i)
+!         ENDIF
+!IM ---
+!       ENDDO
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+!       IF(zri1(i).LT.0.) THEN
+!         IF(nsrf.EQ.1) THEN
+!           ok_pred(i)=1.
+!           ok_corr(i)=0.
+!         ELSE
+!           ok_pred(i)=0.
+!           ok_corr(i)=1.
+!         ENDIF
+!       ELSE
+!         ok_pred(i)=0.
+!         ok_corr(i)=1.
+!       ENDIF
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!IM +++
+!       IF(n.EQ.niter) THEN
+!       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
+!         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
+!         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ENDIF
+!       ENDIF
+!IM ---
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+        u_zref_p(i) = u_zref(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq)
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i)
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                   (1 + RVTMP2 * max(q_zref(i),0.0))
+        ENDDO 
+!
+      ENDDO
+!
+      DO i = 1, knon
+        u_zref_c(i) = u_zref(i)
+!
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+!
+!AM
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!MA
+      ENDDO
+! 
+      RETURN
+      END subroutine stdlevvar
Index: LMDZ4/tags/LF_20080728/libf/phylmd/stratocu_if.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/stratocu_if.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/stratocu_if.F90	(revision 984)
@@ -0,0 +1,78 @@
+  SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t &
+,seuil_inversion,weak_inversion,dthmin)
+implicit none
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! klon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! weak_inversion-----logical
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: klon,klev
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, 4), INTENT(IN)   ::  pctsrf
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t
+    
+    REAL, DIMENSION(klon), INTENT(OUT)  :: weak_inversion
+!
+! Quelques constantes et options:
+!
+    REAL seuil_inversion ! au-dela l'inversion est consideree trop faible
+!    PARAMETER (seuil=-0.1)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(klon)
+    REAL zl2(klon)
+    REAL dthmin(klon), zdthdp
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+!
+! Chercher la zone d'inversion forte
+!
+
+    DO i = 1, klon
+       invb(i) = klev
+       dthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, klon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.dthmin(i) ) THEN
+             dthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+!
+! Introduire une diffusion:
+!
+    DO i = 1, klon
+       IF ( (pctsrf(i,is_oce) < 0.5) .OR. &
+          (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN 
+          weak_inversion(i)=1.
+       ELSE
+          weak_inversion(i)=0.
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE stratocu_if
Index: LMDZ4/tags/LF_20080728/libf/phylmd/suphel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/suphel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/suphel.F	(revision 984)
@@ -0,0 +1,211 @@
+!
+! $Header$
+!
+      SUBROUTINE suphel
+C
+#include "YOMCST.h"
+#include "YOETHF.h"
+cIM cf. JLD
+       LOGICAL firstcall
+       SAVE firstcall
+c$OMP THREADPRIVATE(firstcall)
+       DATA firstcall /.TRUE./
+       
+       IF (firstcall) THEN
+         PRINT*, 'suphel initialise les constantes du GCM'
+         firstcall = .FALSE.
+       ELSE
+         PRINT*, 'suphel DEJA APPELE '
+         RETURN
+       ENDIF
+C      -----------------------------------------------------------------
+C
+C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
+C              -----------------------------
+C
+      WRITE(UNIT=6,FMT='(''0*** Constants of the ICM   ***'')')
+      RPI=2.*ASIN(1.)
+      RCLUM=299792458.
+      RHPLA=6.6260755E-34
+      RKBOL=1.380658E-23
+      RNAVO=6.0221367E+23
+      WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')')
+      WRITE(UNIT=6,FMT='(''           PI = '',E13.7,'' -'')')RPI
+      WRITE(UNIT=6,FMT='(''            c = '',E13.7,''m s-1'')')
+     S RCLUM
+      WRITE(UNIT=6,FMT='(''            h = '',E13.7,''J s'')')
+     S RHPLA
+      WRITE(UNIT=6,FMT='(''            K = '',E13.7,''J K-1'')')
+     S RKBOL
+      WRITE(UNIT=6,FMT='(''            N = '',E13.7,''mol-1'')')
+     S RNAVO
+C
+C     ----------------------------------------------------------------
+C
+C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
+C              ------------------------------
+C
+      RDAY=86400.
+      REA=149597870000.
+      REPSM=0.409093
+C
+      RSIYEA=365.25*RDAY*2.*RPI/6.283076
+      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
+      ROMEGA=2.*RPI/RSIDAY
+c
+c exp1      R_ecc = 0.05
+c exp1      R_peri = 102.04
+c exp1      R_incl = 22.5
+c exp1      print*, 'Parametres orbitaux modifies'
+c ref      R_ecc = 0.016724
+c ref      R_peri = 102.04
+c ref      R_incl = 23.5
+c
+cIM 161002 : pour avoir les ctes AMIP II
+cIM 161002   R_ecc = 0.016724
+cIM 161002   R_peri = 102.04
+cIM 161002   R_incl = 23.5
+cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
+c     R_ecc = 0.016715
+c     R_peri = 102.7
+c     R_incl = 23.441
+c
+      WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')')
+      WRITE(UNIT=6,FMT='(''          day = '',E13.7,'' s'')')RDAY
+      WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA
+      WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
+      WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA
+      WRITE(UNIT=6,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
+      WRITE(UNIT=6,FMT='(''        omega = '',E13.7,'' s-1'')')
+     S                  ROMEGA
+c     write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+c     write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+c     write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+C
+C     ------------------------------------------------------------------
+C
+C*       3.    DEFINE GEOIDE.
+C              --------------
+C
+      RG=9.80665
+      RA=6371229.
+      R1SA=SNGL(1.D0/DBLE(RA))
+      WRITE(UNIT=6,FMT='('' ***         Geoide         ***'')')
+      WRITE(UNIT=6,FMT='(''      Gravity = '',E13.7,'' m s-2'')')
+     S      RG
+      WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA
+      WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA
+C
+C     -----------------------------------------------------------------
+C
+C*       4.    DEFINE RADIATION CONSTANTS.
+C              ---------------------------
+C
+c z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+      rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15.
+cIM init. dans conf_phys.F90   RI0=1365.
+      WRITE(UNIT=6,FMT='('' ***        Radiation       ***'')')
+      WRITE(UNIT=6,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''
+     S )')  RSIGMA
+cIM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
+cIM init. dans conf_phys.F90  S      RI0
+C
+C     -----------------------------------------------------------------
+C
+C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+C              ------------------------------------------
+C
+      R=RNAVO*RKBOL
+      RMD=28.9644
+      RMO3=47.9942
+      RMV=18.0153
+      RD=1000.*R/RMD
+      RV=1000.*R/RMV
+      RCPD=3.5*RD
+      RCVD=RCPD-RD
+      RCPV=4. *RV
+      RCVV=RCPV-RV
+      RKAPPA=RD/RCPD
+      RETV=RV/RD-1.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas     ***'')')
+      WRITE(UNIT=6,FMT='('' Perfect gas  = '',e13.7)') R
+      WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD
+      WRITE(UNIT=6,FMT='('' Ozone   mass = '',e13.7)') RMO3
+      WRITE(UNIT=6,FMT='('' Vapour  mass = '',e13.7)') RMV
+      WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD
+      WRITE(UNIT=6,FMT='('' Vapour  cst. = '',e13.7)') RV
+      WRITE(UNIT=6,FMT='(''         Cpd  = '',e13.7)') RCPD
+      WRITE(UNIT=6,FMT='(''         Cvd  = '',e13.7)') RCVD
+      WRITE(UNIT=6,FMT='(''         Cpv  = '',e13.7)') RCPV
+      WRITE(UNIT=6,FMT='(''         Cvv  = '',e13.7)') RCVV
+      WRITE(UNIT=6,FMT='(''      Rd/Cpd  = '',e13.7)') RKAPPA
+      WRITE(UNIT=6,FMT='(''     Rv/Rd-1  = '',e13.7)') RETV
+C
+C     ----------------------------------------------------------------
+C
+C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+C              ---------------------------------------------
+C
+      RCW=RCPV
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid  ***'')')
+      WRITE(UNIT=6,FMT='(''         Cw   = '',E13.7)') RCW
+C
+C     ----------------------------------------------------------------
+C
+C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+C              --------------------------------------------
+C
+      RCS=RCPV
+      WRITE(UNIT=6,FMT='('' *** thermodynamic, solid   ***'')')
+      WRITE(UNIT=6,FMT='(''         Cs   = '',E13.7)') RCS
+C
+C     ----------------------------------------------------------------
+C
+C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+C              ----------------------------------------------------
+C
+      RTT=273.16
+      RLVTT=2.5008E+6
+      RLSTT=2.8345E+6
+      RLMLT=RLSTT-RLVTT
+      RATM=100000.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans.  ***'')')
+      WRITE(UNIT=6,FMT='('' Fusion point  = '',E13.7)') RTT
+      WRITE(UNIT=6,FMT='(''        RLvTt  = '',E13.7)') RLVTT
+      WRITE(UNIT=6,FMT='(''        RLsTt  = '',E13.7)') RLSTT
+      WRITE(UNIT=6,FMT='(''        RLMlt  = '',E13.7)') RLMLT
+      WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM
+      WRITE(UNIT=6,FMT='('' Latent heat :  '')')
+C
+C     ----------------------------------------------------------------
+C
+C*       9.    SATURATED VAPOUR PRESSURE.
+C              --------------------------
+C
+      RESTT=611.14
+      RGAMW=(RCW-RCPV)/RV
+      RBETW=RLVTT/RV+RGAMW*RTT
+      RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
+      RGAMS=(RCS-RCPV)/RV
+      RBETS=RLSTT/RV+RGAMS*RTT
+      RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
+      RGAMD=RGAMS-RGAMW
+      RBETD=RBETS-RBETW
+      RALPD=RALPS-RALPW
+C
+C     ------------------------------------------------------------------
+c
+c calculer les constantes pour les fonctions thermodynamiques
+c
+      RVTMP2=RCPV/RCPD-1.
+      RHOH2O=RATM/100.
+      R2ES=RESTT*RD/RV
+      R3LES=17.269
+      R3IES=21.875
+      R4LES=35.86
+      R4IES=7.66
+      R5LES=R3LES*(RTT-R4LES)
+      R5IES=R3IES*(RTT-R4IES)
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_bucket_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_bucket_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_bucket_mod.F90	(revision 984)
@@ -0,0 +1,329 @@
+!
+! $Header$
+!
+MODULE surf_land_bucket_mod
+!
+! Surface land bucket module
+!
+! This module is used when no external land model is choosen.
+!
+  USE fonte_neige_mod
+  USE calcul_fluxs_mod
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+ 
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+       spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, &
+       u1_lay, v1_lay, rugoro, swnet, lwnet, &
+       snow, qsol, agesno, tsoil, &
+       qsurf, z0_new, alb1_new, alb2_new, evap, &
+       fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+
+!****************************************************************************************
+! Bucket calculations for surface. 
+!
+    INCLUDE "clesphys.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    LOGICAL, INTENT(IN)                     :: debut
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: pref
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+    REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: soilcap, soilflux
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon) :: alb_neig, alb_lim
+    REAL, DIMENSION(klon) :: zfra
+    REAL, DIMENSION(klon) :: radsol       ! total net radiance at surface
+    INTEGER               :: i
+!
+!****************************************************************************************
+
+
+!
+!* Read from limit.nc : albedo(alb_lim), length of rugosity(z0_new)
+!
+    CALL interfsur_lim(itime, dtime, jour, &
+         knon, knindex, debut,  &
+         alb_lim, z0_new)
+    
+!
+!* Calcultaion of fluxes 
+!
+
+! calculate total absorbed radiance at surface
+       radsol(:) = 0.0
+       radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+! calculate constants
+    CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
+       
+! calculate temperature, heat capacity and conduction flux in soil
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       DO i=1, knon
+          cal(i) = RCPD / soilcap(i)
+          radsol(i) = radsol(i)  + soilflux(i)
+       END DO
+    ELSE 
+       cal(:) = RCPD * capsol(:)
+    ENDIF
+    
+    CALL calcul_fluxs(knon, is_ter, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, pref, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+!
+!* Calculate snow height, run_off, age of snow
+!      
+    CALL fonte_neige( knon, is_ter, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+!
+!* Calculate the age of snow
+!
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    
+    DO i=1, knon
+       zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0)))
+       alb_lim(i)  = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i))
+    END DO
+
+!
+!* Return albedo : 
+!    alb1_new and alb2_new are here given the same values
+!
+    alb1_new(:) = 0.0
+    alb2_new(:) = 0.0
+    alb1_new(1:knon) = alb_lim(1:knon)
+    alb2_new(1:knon) = alb_lim(1:knon)
+       
+!
+!* Calculate the rugosity
+!
+    z0_new = SQRT(z0_new**2+rugoro**2)
+       
+!
+!* End
+!
+  END SUBROUTINE surf_land_bucket
+!
+!****************************************************************************************
+!
+  SUBROUTINE interfsur_lim(itime, dtime, jour, &
+       knon, knindex, debut, &
+       lmt_alb_p, lmt_rug_p)
+    
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_alb_p      Albedo lu 
+!   lmt_rug_p      longueur de rugosite lue
+
+    INCLUDE "netcdf.inc"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime
+    REAL   , INTENT(IN)                      :: dtime
+    INTEGER, INTENT(IN)                      :: jour
+    INTEGER, INTENT(IN)                      :: knon
+    INTEGER, DIMENSION(klon_loc), INTENT(IN) :: knindex
+    LOGICAL, INTENT(IN)                      :: debut
+
+! Output variables
+!****************************************************************************************
+    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_alb_p
+    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_rug_p
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER,SAVE   :: lmt_pas     ! frequence de lecture des conditions limites 
+                                  ! (en pas de physique)
+    !$OMP THREADPRIVATE(lmt_pas) 
+    LOGICAL,SAVE   :: deja_lu_sur ! pour indiquer que le jour a lire a deja
+                                  ! lu pour une surface precedente
+    !$OMP THREADPRIVATE(deja_lu_sur) 
+    INTEGER,SAVE                           :: jour_lu_sur 
+    !$OMP THREADPRIVATE(jour_lu_sur) 
+    CHARACTER (len = 20),SAVE              :: fich ='limit.nc'
+    !$OMP THREADPRIVATE(fich) 
+    LOGICAL,SAVE                           :: check = .FALSE.
+    !$OMP THREADPRIVATE(check) 
+! Champs lus dans le fichier de CL
+    REAL, ALLOCATABLE , SAVE, DIMENSION(:) :: alb_lu_p, rug_lu_p
+    !$OMP THREADPRIVATE(alb_lu_p, rug_lu_p) 
+
+! quelques variables pour netcdf
+    INTEGER ,SAVE                          :: nid, nvarid
+    !$OMP THREADPRIVATE(nid, nvarid) 
+    INTEGER, DIMENSION(2),SAVE             :: start, epais
+    !$OMP THREADPRIVATE(start, epais) 
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                :: ii, ierr
+    CHARACTER (len = 20)                   :: modname = 'interfsur_lim'
+    CHARACTER (len = 80)                   :: abort_message
+    REAL, DIMENSION(klon_glo)              :: alb_lu
+    REAL, DIMENSION(klon_glo)              :: rug_lu
+
+!
+! End delaration
+!****************************************************************************************
+
+    IF (debut) THEN
+       lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+       jour_lu_sur = jour - 1
+       ALLOCATE(alb_lu_p(klon_loc))
+       ALLOCATE(rug_lu_p(klon_loc))
+    ENDIF
+    
+    IF ((jour - jour_lu_sur) /= 0) deja_lu_sur = .FALSE.
+  
+    IF (check) WRITE(*,*) modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur 
+    IF (check) WRITE(*,*) modname,':: itime, lmt_pas', itime, lmt_pas
+    IF (check) CALL flush(6)
+
+!    
+! Tester d'abord si c'est le moment de lire le fichier
+!
+    IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu_sur) THEN
+
+!
+! Ouverture et lecture du fichier
+!
+!$OMP MASTER
+       IF (is_mpi_root) THEN
+          fich = TRIM(fich)
+          IF (check) WRITE(*,*)modname,' ouverture fichier ',fich
+          IF (check) CALL flush(6)
+          ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+          IF (ierr.NE.NF_NOERR) THEN
+             abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+! 
+! La tranche de donnees a lire:
+          start(1) = 1
+          start(2) = jour
+          epais(1) = klon_glo
+          epais(2) = 1
+!
+! Lecture albedo
+          ierr = NF_INQ_VARID(nid, 'ALB', nvarid)
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Le champ <ALB> est absent'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, alb_lu)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu)
+#endif
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Lecture echouee pour <ALB>'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+!
+! Lecture rugosite!
+          ierr = NF_INQ_VARID(nid, 'RUG', nvarid)
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Le champ <RUG> est absent'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, rug_lu)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu)
+#endif
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Lecture echouee pour <RUG>'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+
+!
+! Fin de lecture
+          ierr = NF_CLOSE(nid)
+
+       ENDIF ! is_mpi_root
+!$OMP END MASTER
+
+       CALL Scatter(alb_lu,alb_lu_p)
+       CALL Scatter(rug_lu,rug_lu_p)
+
+       deja_lu_sur = .TRUE.
+       jour_lu_sur = jour       
+
+    ENDIF
+  
+!
+! Recopie des variables dans les champs de sortie
+!
+    lmt_alb_p(:) = 999999.
+    lmt_rug_p(:) = 999999.
+    DO ii = 1, knon
+       lmt_alb_p(ii) = alb_lu_p(knindex(ii))
+       lmt_rug_p(ii) = rug_lu_p(knindex(ii))
+    ENDDO
+    
+
+  END SUBROUTINE interfsur_lim
+!
+!****************************************************************************************
+!
+END MODULE surf_land_bucket_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_mod.F90	(revision 984)
@@ -0,0 +1,170 @@
+!
+! $Header$
+!
+MODULE surf_land_mod
+  
+  USE surface_data, ONLY    : ok_veget
+  USE dimphy
+ 
+#ifdef CPP_VEGET
+  USE surf_land_orchidee_mod
+#endif
+  USE surf_land_bucket_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
+       rlon, rlat, &
+       debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       pref, u1_lay, v1_lay, rugoro, pctsrf, &
+       snow, qsol, agesno, tsoil, &
+       z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       qsurf, tsurf_new, dflux_s, dflux_l, pctsrf_ter, &
+       lwdown_m)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: date0
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    LOGICAL, INTENT(IN)                     :: debut, lafin
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: zlev, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
+    REAL, DIMENSION(klon), INTENT(IN)       :: albedo  ! albedo for whole short-wave interval
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: pref   ! pressure reference
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+    REAL, DIMENSION(klon), INTENT(IN)       :: lwdown_m  ! downwelling longwave radiation at mean surface
+                                                         ! corresponds to previous sollwdown
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new ! albedo for shortwave interval 2(near infrared)
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap
+    REAL, DIMENSION(klon), INTENT(OUT)       :: fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_ter
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: p1lay_tmp
+    REAL, DIMENSION(klon) :: pref_tmp
+    REAL, DIMENSION(klon) :: swdown     ! downwelling shortwave radiation at land surface
+    REAL, DIMENSION(klon) :: lwdown     ! downwelling longwave radiation at land surface
+    REAL, DIMENSION(klon) :: epot_air           ! potential air temperature
+    REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used
+    INTEGER               :: i
+
+
+!**************************************************************************************** 
+! Choice between call to vegetation model (ok_veget=true) or simple calculation below
+!
+!****************************************************************************************
+   IF (ok_veget) THEN
+!****************************************************************************************
+!  Call model sechiba in model ORCHIDEE
+!
+!****************************************************************************************
+       p1lay_tmp(:)      = 0.0
+       pref_tmp(:)       = 0.0
+       p1lay_tmp(1:knon) = p1lay(1:knon)/100.
+       pref_tmp(1:knon)  = pref(1:knon)/100.
+! 
+!* Calculate incoming flux for SW and LW interval: swdown, lwdown
+!
+       swdown(:) = 0.0
+       lwdown(:) = 0.0
+       DO i = 1, knon
+          swdown(i) = swnet(i)/(1-albedo(i))
+          lwdown(i) = lwnet(i) + RSIGMA*tsurf(i)**4
+       END DO
+!
+!* Calculate potential air temperature
+!
+       epot_air(:) = 0.0
+       DO i = 1, knon
+          epot_air(i) = RCPD*temp_air(i)*(pref(i)/p1lay(i))**RKAPPA
+       END DO
+
+#ifdef CPP_VEGET
+       ! temporary for keeping same results using lwdown_m instead of lwdown
+       CALL surf_land_orchidee(itime, dtime, date0, knon, &
+            knindex, rlon, rlat, pctsrf, &
+            debut, lafin, &
+            zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+            tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            precip_rain, precip_snow, lwdown_m, swnet, swdown, &
+            pref_tmp, &
+            evap, fluxsens, fluxlat, &              
+            tsol_rad, tsurf_new, alb1_new, alb2_new, &
+            emis_new, z0_new, qsurf)       
+#endif
+
+!  
+!* Add contribution of relief to surface roughness
+!  
+       DO i=1,knon
+          z0_new(i) = SQRT(z0_new(i)**2 + rugoro(i)**2)
+       ENDDO
+
+    ELSE  ! not ok_veget
+!****************************************************************************************
+! No extern vegetation model choosen, call simple bucket calculations instead.
+!
+!****************************************************************************************
+       CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+            tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+            spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, &
+            u1_lay, v1_lay, rugoro, swnet, lwnet, &
+            snow, qsol, agesno, tsoil, &
+            qsurf, z0_new, alb1_new, alb2_new, evap, &
+            fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+
+    ENDIF ! ok_veget
+
+!****************************************************************************************
+! Return the pourcentage of land in each grid cell, even if not changed in here!
+!
+!****************************************************************************************
+    pctsrf_ter(:) = pctsrf(:,is_ter)
+
+
+  END SUBROUTINE surf_land
+!
+!****************************************************************************************
+!  
+END MODULE surf_land_mod
+!
+!****************************************************************************************
+!  
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_orchidee_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_orchidee_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surf_land_orchidee_mod.F90	(revision 984)
@@ -0,0 +1,703 @@
+!
+! $Header$
+!
+MODULE surf_land_orchidee_mod
+!
+! This module controles the interface towards the model ORCHIDEE
+!
+! Subroutines in this module : surf_land_orchidee
+!                              Init_orchidee_index
+!                              Get_orchidee_communicator
+!                              Init_neighbours
+#ifdef CPP_VEGET
+
+  USE dimphy
+  USE intersurf     ! module d'ORCHIDEE
+  USE cpl_mod,      ONLY : cpl_send_land_fields
+  USE surface_data, ONLY : ocean, ok_veget
+  USE comgeomphy,   ONLY : cuphy, cvphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC  :: surf_land_orchidee
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
+       knindex, rlon, rlat, pctsrf, &
+       debut, lafin, &
+       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       precip_rain, precip_snow, lwdown, swnet, swdown, &
+       ps, &
+       evap, fluxsens, fluxlat, &              
+       tsol_rad, tsurf_new, alb1_new, alb2_new, &
+       emis_new, z0_new, qsurf)
+!    
+! Cette routine sert d'interface entre le modele atmospherique et le 
+! modele de sol continental. Appel a sechiba
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes de la grille entiere
+!   rlat         latitudes de la grille entiere
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   debut        logical: 1er appel a la physique (lire les restart)
+!   lafin        logical: dernier appel a la physique (ecrire les restart)
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   plev         hauteur de la premiere couche (Pa)      
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp pot de l'air
+!   ccanopy      concentration CO2 canopee
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   lwdown       flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb1_new     albedo in visible SW interval
+!   alb2_new     albedo in near IR interval
+!   emis_new     emissivite
+!   z0_new       surface roughness
+!   qsurf        air moisture at surface
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "dimensions.h"
+  
+!
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    REAL, INTENT(IN)                          :: dtime
+    REAL, INTENT(IN)                          :: date0
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    LOGICAL, INTENT(IN)                       :: debut, lafin
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
+    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)         :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)         :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)         :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)         :: lwdown, swnet, swdown, ps
+    REAL, DIMENSION(klon)                     :: swdown_vrai
+
+! Parametres de sortie
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: evap, fluxsens, fluxlat, qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tsol_rad, tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)        :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)        :: emis_new, z0_new
+
+! Local
+!****************************************************************************************
+    INTEGER                                   :: ij, jj, igrid, ireal, index
+    INTEGER                                   :: error
+    CHARACTER (len = 20)                      :: modname = 'surf_land_orchidee'
+    CHARACTER (len = 80)                      :: abort_message
+    LOGICAL,SAVE                              :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! type de couplage dans sechiba
+!  character (len=10)   :: coupling = 'implicit' 
+! drapeaux controlant les appels dans SECHIBA
+!  type(control_type), save   :: control_in
+! Preserved albedo
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: albedo_keep, zlev
+    !$OMP THREADPRIVATE(albedo_keep,zlev)
+! coordonnees geographiques
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
+    !$OMP THREADPRIVATE(lalo)
+! pts voisins
+    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
+    !$OMP THREADPRIVATE(neighbours)
+! fractions continents
+    REAL,ALLOCATABLE, DIMENSION(:), SAVE      :: contfrac
+    !$OMP THREADPRIVATE(contfrac)
+! resolution de la grille
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: resolution
+    !$OMP THREADPRIVATE(resolution)
+
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: lon_scat, lat_scat  
+    !$OMP THREADPRIVATE(lon_scat,lat_scat)
+
+    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
+    !$OMP THREADPRIVATE(lrestart_read)
+    LOGICAL, SAVE                             :: lrestart_write = .FALSE.
+    !$OMP THREADPRIVATE(lrestart_write)
+
+    REAL, DIMENSION(knon,2)                   :: albedo_out
+    !$OMP THREADPRIVATE(albedo_out)
+
+! Pb de nomenclature
+    REAL, DIMENSION(klon)                     :: petA_orc, peqA_orc
+    REAL, DIMENSION(klon)                     :: petB_orc, peqB_orc
+! Pb de correspondances de grilles
+    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  :: ig, jg
+    !$OMP THREADPRIVATE(ig,jg)
+    INTEGER :: indi, indj
+    INTEGER, SAVE, ALLOCATABLE,DIMENSION(:)   :: ktindex
+    !$OMP THREADPRIVATE(ktindex)
+
+! Essai cdrag
+    REAL, DIMENSION(klon)                     :: cdrag
+    INTEGER,SAVE                              :: offset
+    !$OMP THREADPRIVATE(offset)
+
+    REAL, DIMENSION(klon_glo)                 :: rlon_g,rlat_g
+    INTEGER, SAVE                             :: orch_comm
+    !$OMP THREADPRIVATE(orch_comm)
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: coastalflow
+    !$OMP THREADPRIVATE(coastalflow)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: riverflow
+    !$OMP THREADPRIVATE(riverflow)
+!
+! Fin definition
+!****************************************************************************************
+
+    IF (check) WRITE(lunout,*)'Entree ', modname
+    IF (check) WRITE(lunout,*)'ok_veget = ',ok_veget
+  
+! Initialisation
+  
+    IF (debut) THEN
+       ALLOCATE(ktindex(knon))
+       IF ( .NOT. ALLOCATED(albedo_keep)) THEN
+          ALLOCATE(albedo_keep(klon))
+          ALLOCATE(zlev(knon))
+       ENDIF
+! Pb de correspondances de grilles
+       ALLOCATE(ig(klon))
+       ALLOCATE(jg(klon))
+       ig(1) = 1
+       jg(1) = 1
+       indi = 0
+       indj = 2
+       DO igrid = 2, klon - 1
+          indi = indi + 1
+          IF ( indi > iim) THEN
+             indi = 1
+             indj = indj + 1
+          ENDIF
+          ig(igrid) = indi
+          jg(igrid) = indj
+       ENDDO
+       ig(klon) = 1
+       jg(klon) = jjm + 1
+
+       IF ((.NOT. ALLOCATED(lalo))) THEN
+          ALLOCATE(lalo(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lalo'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lon_scat))) THEN
+          ALLOCATE(lon_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lon_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lat_scat))) THEN
+          ALLOCATE(lat_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lat_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       lon_scat = 0.
+       lat_scat = 0.
+       DO igrid = 1, knon
+          index = knindex(igrid)
+          lalo(igrid,2) = rlon(index)
+          lalo(igrid,1) = rlat(index)
+       ENDDO
+
+       
+       
+       CALL Gather(rlon,rlon_g)
+       CALL Gather(rlat,rlat_g)
+
+       IF (is_mpi_root) THEN
+          index = 1
+          DO jj = 2, jjm
+             DO ij = 1, iim
+                index = index + 1
+                lon_scat(ij,jj) = rlon_g(index)
+                lat_scat(ij,jj) = rlat_g(index)
+             ENDDO
+          ENDDO
+          lon_scat(:,1) = lon_scat(:,2)
+          lat_scat(:,1) = rlat_g(1)
+          lon_scat(:,jjm+1) = lon_scat(:,2)
+          lat_scat(:,jjm+1) = rlat_g(klon_glo)
+       ENDIF
+   
+
+!
+! Allouer et initialiser le tableau des voisins et des fraction de continents
+!
+       IF ( (.NOT.ALLOCATED(neighbours))) THEN
+          ALLOCATE(neighbours(knon,8), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation neighbours'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       neighbours = -1.
+       IF (( .NOT. ALLOCATED(contfrac))) THEN
+          ALLOCATE(contfrac(knon), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation contfrac'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       DO igrid = 1, knon
+          ireal = knindex(igrid)
+          contfrac(igrid) = pctsrf(ireal,is_ter)
+       ENDDO
+
+
+       CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
+
+!
+!  Allocation et calcul resolutions
+       IF ( (.NOT.ALLOCATED(resolution))) THEN
+          ALLOCATE(resolution(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation resolution'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       DO igrid = 1, knon
+          ij = knindex(igrid)
+          resolution(igrid,1) = cuphy(ij)
+          resolution(igrid,2) = cvphy(ij)
+       ENDDO
+     
+       ALLOCATE(coastalflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation coastalflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+       ALLOCATE(riverflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation riverflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+
+    ENDIF                          ! (fin debut) 
+
+! 
+! Appel a la routine sols continentaux
+!
+    IF (lafin) lrestart_write = .TRUE.
+    IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
+    
+    petA_orc(1:knon) = petBcoef(1:knon) * dtime
+    petB_orc(1:knon) = petAcoef(1:knon)
+    peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
+    peqB_orc(1:knon) = peqAcoef(1:knon)
+
+    cdrag = 0.
+    cdrag(1:knon) = tq_cdrag(1:knon)
+
+! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
+    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
+
+
+! PF et PASB
+!   where(cdrag > 0.01) 
+!     cdrag = 0.01
+!   endwhere
+!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
+
+!
+! Init Orchidee
+!
+!  if (pole_nord) then 
+!    offset=0
+!    ktindex(:)=ktindex(:)+iim-1
+!  else
+!    offset = klon_mpi_begin-1+iim-1
+!    ktindex(:)=ktindex(:)+MOD(offset,iim)
+!    offset=offset-MOD(offset,iim)
+!  endif
+  
+    IF (debut) THEN
+       CALL Get_orchidee_communicator(knon,orch_comm)
+       IF (knon /=0) THEN
+          CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+
+#ifndef CPP_PARA
+#define ORC_PREPAR
+#endif
+#ifdef ORC_PREPAR
+          ! Interface for ORCHIDEE version 1.9 or earlier compiled in sequential mode(without preprocessing flag CPP_PARA)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
+               lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+               cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+               precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
+               evap, fluxsens, fluxlat, coastalflow, riverflow, &
+               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+               lon_scat, lat_scat)
+
+#else          
+          ! Interface for ORCHIDEE version 1.9 compiled in parallel mode(with preprocessing flag CPP_PARA)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, & 
+               orch_comm, dtime, lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+               cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+               precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), &
+               evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+               tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+               lon_scat, lat_scat)
+#endif
+          
+       ENDIF
+
+       albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+    ENDIF
+
+!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
+    swdown_vrai(1:knon) = swdown(1:knon)
+
+    IF (knon /=0) THEN
+    
+#ifdef ORC_PREPAR
+       ! Interface for ORCHIDEE version 1.9 or earlier compiled in sequential mode(without preprocessing flag CPP_PARA)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, &
+            lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+            cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+            precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
+            evap, fluxsens, fluxlat, coastalflow, riverflow, &
+            tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+            lon_scat, lat_scat)
+       
+#else
+       ! Interface for ORCHIDEE version 1.9 compiled in parallel mode(with preprocessing flag CPP_PARA)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & 
+            orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+            cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+            precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
+            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+            lon_scat, lat_scat)
+#endif
+       
+    ENDIF
+
+    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+!* Send to coupler
+!
+    IF (ocean=='couple') THEN
+       CALL cpl_send_land_fields(itime, knon, knindex, &
+            riverflow, coastalflow)
+    ENDIF
+
+    alb1_new(1:knon) = albedo_out(1:knon,1) 
+    alb2_new(1:knon) = albedo_out(1:knon,2)
+
+! Convention orchidee: positif vers le haut
+    fluxsens(1:knon) = -1. * fluxsens(1:knon)
+    fluxlat(1:knon)  = -1. * fluxlat(1:knon)
+    
+!  evap     = -1. * evap
+
+    IF (debut) lrestart_read = .FALSE.
+    
+  END SUBROUTINE surf_land_orchidee
+!
+!****************************************************************************************
+!
+  SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+    
+    INCLUDE "dimensions.h"
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                   :: knon
+    INTEGER, INTENT(IN)                   :: orch_comm
+    INTEGER, DIMENSION(klon), INTENT(IN)  :: knindex
+
+! Output arguments
+!****************************************************************************************
+    INTEGER, INTENT(OUT)                  :: offset
+    INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex
+
+! Local varables
+!****************************************************************************************
+#ifdef CPP_PARA
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: status
+#endif
+
+    INTEGER                               :: MyLastPoint
+    INTEGER                               :: LastPoint
+    INTEGER                               :: mpi_rank_orch
+    INTEGER                               :: mpi_size_orch
+    INTEGER                               :: ierr 
+!
+! End definition
+!****************************************************************************************
+
+    MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1
+    
+    IF (is_parallel) THEN
+#ifdef CPP_PARA    
+       CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr)
+       CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr)
+#endif
+    ELSE
+       mpi_rank_orch=0
+       mpi_size_orch=1
+    ENDIF
+
+    IF (is_parallel) THEN
+       IF (mpi_rank_orch /= 0) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr)
+#endif
+       ENDIF
+       
+       IF (mpi_rank_orch /= mpi_size_orch-1) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr)  
+#endif
+       ENDIF
+    ENDIF
+    
+    IF (mpi_rank_orch == 0) THEN 
+       offset=0
+    ELSE
+       offset=LastPoint-MOD(LastPoint,iim)
+    ENDIF
+    
+    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1	
+    
+
+  END SUBROUTINE  Init_orchidee_index
+!
+!****************************************************************************************
+! 
+  SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+
+    INTEGER,INTENT(IN)  :: knon
+    INTEGER,INTENT(OUT) :: orch_comm
+    
+    INTEGER             :: color
+    INTEGER             :: ierr
+!
+! End definition
+!****************************************************************************************
+
+    IF (knon==0) THEN 
+       color = 0
+    ELSE 
+       color = 1
+    ENDIF
+    
+#ifdef CPP_PARA    
+    CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
+#endif
+    
+  END SUBROUTINE Get_orchidee_communicator
+!
+!****************************************************************************************
+!  
+  SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf)
+    
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: ktindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: pctsrf
+    
+! Output arguments
+!****************************************************************************************
+    INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: knon_g
+    INTEGER                              :: i, igrid, jj, ij, iglob
+    INTEGER                              :: ierr, ireal, index
+    INTEGER, DIMENSION(0:mpi_size-1)     :: knon_nb
+    INTEGER, DIMENSION(0:mpi_size-1)     :: displs
+    INTEGER, DIMENSION(8,3)              :: off_ini
+    INTEGER, DIMENSION(8)                :: offset  
+    INTEGER, DIMENSION(knon)             :: ktindex_p
+    INTEGER, DIMENSION(iim,jjm+1)        :: correspond
+    INTEGER, ALLOCATABLE, DIMENSION(:)   :: ktindex_g
+    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
+    REAL, DIMENSION(klon_glo)            :: pctsrf_g
+    
+!
+! End definition
+!****************************************************************************************
+
+    IF (is_sequential) THEN
+       knon_nb(:)=knon
+    ELSE  
+       
+#ifdef CPP_PARA  
+       CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+       knon_g=SUM(knon_nb(:))
+       ALLOCATE(ktindex_g(knon_g))
+       ALLOCATE(neighbours_g(knon_g,8))
+       neighbours_g(:,:)=-1
+       displs(0)=0
+       DO i=1,mpi_size-1
+          displs(i)=displs(i-1)+knon_nb(i-1)
+       ENDDO
+    ENDIF
+    
+    ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1
+    
+    IF (is_sequential) THEN
+       ktindex_g(:)=ktindex_p(:)
+    ELSE
+       
+#ifdef CPP_PARA  
+       CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,&
+            displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    CALL Gather(pctsrf,pctsrf_g)
+    
+    IF (is_mpi_root) THEN
+!  Initialisation des offset    
+!
+! offset bord ouest
+       off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
+       off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
+       off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
+! offset point normal
+       off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
+       off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
+       off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
+! offset bord   est
+       off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
+       off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
+       off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
+!
+!
+! Attention aux poles
+!
+       DO igrid = 1, knon_g
+          index = ktindex_g(igrid)
+          jj = INT((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+          correspond(ij,jj) = igrid
+       ENDDO
+       
+       DO igrid = 1, knon_g
+          iglob = ktindex_g(igrid)
+          IF (MOD(iglob, iim) == 1) THEN
+             offset = off_ini(:,1)
+          ELSE IF(MOD(iglob, iim) == 0) THEN
+             offset = off_ini(:,3)
+          ELSE
+             offset = off_ini(:,2)
+          ENDIF
+          DO i = 1, 8
+             index = iglob + offset(i)
+             ireal = (MIN(MAX(1, index - iim + 1), klon_glo))
+             IF (pctsrf_g(ireal) > EPSFRA) THEN
+                jj = INT((index - 1)/iim) + 1
+                ij = index - (jj - 1) * iim
+                neighbours_g(igrid, i) = correspond(ij, jj)
+             ENDIF
+          ENDDO
+       ENDDO
+
+    ENDIF
+    
+    DO i=1,8
+       IF (is_sequential) THEN
+          neighbours(:,i)=neighbours_g(:,i)
+       ELSE
+#ifdef CPP_PARA
+          CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) 
+#endif
+       ENDIF
+    ENDDO
+    
+  END SUBROUTINE Init_neighbours
+!
+!****************************************************************************************
+!
+
+#endif
+
+END MODULE surf_land_orchidee_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surf_landice_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surf_landice_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surf_landice_mod.F90	(revision 984)
@@ -0,0 +1,180 @@
+!
+! $Header$
+!
+MODULE surf_landice_mod
+  
+  USE dimphy
+  USE surface_data,     ONLY : ocean, calice, calsno
+  USE fonte_neige_mod,  ONLY : fonte_neige, run_off_lic
+  USE cpl_mod,          ONLY : cpl_send_landice_fields
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_landice(itime, dtime, knon, knindex, &
+       swnet, lwnet, tsurf, p1lay, &
+       tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_lic)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input variables 
+!****************************************************************************************
+    INTEGER, INTENT(IN)                           :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(in)          :: knindex
+    REAL, INTENT(in)                              :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)             :: swnet ! net shortwave radiance
+    REAL, DIMENSION(klon), INTENT(IN)             :: lwnet ! net longwave radiance
+    REAL, DIMENSION(klon), INTENT(IN)             :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)             :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)             :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)             :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)             :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)             :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)             :: ps
+    REAL, DIMENSION(klon), INTENT(IN)             :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_lic
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)    :: soilcap, soilflux
+    REAL, DIMENSION(klon)    :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)    :: zfra, alb_neig
+    REAL, DIMENSION(klon)    :: radsol
+
+! End definition
+!****************************************************************************************
+!
+! Initialize output variables
+    alb2(:) = 999999.
+    alb1(:) = 999999.
+
+!****************************************************************************************
+! Calculate total absorbed radiance at surface
+!
+!****************************************************************************************
+    radsol(:) = 0.0
+    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+!****************************************************************************************
+! Soil calculations
+! 
+!****************************************************************************************
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_lic, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon)  = radsol(1:knon) + soilflux(1:knon)
+    ELSE 
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno
+    ENDIF
+
+
+!****************************************************************************************
+! Calulate fluxes
+!
+!****************************************************************************************
+    beta(:) = 1.0
+    dif_grnd(:) = 0.0
+
+    CALL calcul_fluxs(knon, is_lic, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+
+!****************************************************************************************
+! Calculate snow height, age, run-off,..
+!    
+!****************************************************************************************
+    CALL fonte_neige( knon, is_lic, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb1(1:knon) = alb_neig(1:knon)*zfra(1:knon) + &
+         0.6 * (1.0-zfra(1:knon))
+!
+!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux"
+!       alb1(1 : knon)  = 0.6 !IM cf FH/GK 
+!       alb1(1 : knon)  = 0.82
+!       alb1(1 : knon)  = 0.77 !211003 Ksta0.77
+!       alb1(1 : knon)  = 0.8 !KstaTER0.8 & LMD_ARMIP5
+!IM: KstaTER0.77 & LMD_ARMIP6    
+
+! Attantion: alb1 and alb2 are the same!
+    alb1(1:knon)  = 0.77
+    alb2(1:knon)  = alb1(1:knon)
+
+
+!****************************************************************************************
+! Rugosity
+!
+!****************************************************************************************
+    z0_new(:) = rugoro(:)
+
+
+!****************************************************************************************
+! Return the pourcentage for this sub-surface
+!
+!****************************************************************************************
+    pctsrf_lic(:) = pctsrf(:,is_lic)
+    
+
+!****************************************************************************************
+! Send run-off on land-ice to coupler if coupled ocean.
+! run_off_lic has been calculated in fonte_neige
+!
+!****************************************************************************************
+    IF (ocean=='couple') THEN
+       CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic)
+    ENDIF
+
+
+  END SUBROUTINE surf_landice
+!
+!****************************************************************************************
+!
+END MODULE surf_landice_mod
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surf_ocean_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surf_ocean_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surf_ocean_mod.F90	(revision 984)
@@ -0,0 +1,172 @@
+!
+! $Header$
+!
+MODULE surf_ocean_mod
+
+  USE dimphy
+  USE surface_data, ONLY     : ocean
+  USE ocean_forced_mod, ONLY : ocean_forced_noice
+  USE ocean_slab_mod, ONLY   : ocean_slab_noice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_noice
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, &
+       rugos, windsp, rmu0, fder, &
+       itime, dtime, jour, knon, knindex, &
+       debut, &
+       p1lay, tq_cdrag, coefm, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       snow, qsurf, agesno, &
+       z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, 
+! slab or couple). The calculations of albedo and rugosity for the ocean surface are 
+! done in here because they are identical for the different modes of ocean. 
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet  ! net shortwave radiation at surface  
+    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)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: coefm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+    LOGICAL, INTENT(IN)                      :: debut
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: qsurf
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    REAL, DIMENSION(klon) :: alb_eau
+    REAL, DIMENSION(klon) :: radsol
+
+! End definition
+!****************************************************************************************
+
+
+!****************************************************************************************
+! Calculate total net radiance at surface
+!
+!****************************************************************************************
+    radsol(:) = 0.0
+    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+!****************************************************************************************
+! Switch according to type of ocean (couple, slab or forced)
+!****************************************************************************************
+    SELECT CASE(ocean)
+    CASE('couple')
+       CALL ocean_cpl_noice( &
+            swnet, lwnet, alb1, &
+            windsp, &
+            fder, & 
+            itime, dtime, knon, knindex, &
+            p1lay, tq_cdrag, precip_rain, precip_snow,temp_air,spechum,&
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, pctsrf, &
+            radsol, snow, agesno, &
+            qsurf, evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+
+    CASE('slab')
+       CALL ocean_slab_noice( &
+            dtime, knon, knindex, &
+            p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, &
+            radsol, snow, agesno, &
+            qsurf, evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+       
+    CASE('force')
+       CALL ocean_forced_noice( &
+            itime, dtime, jour, knon, knindex, &
+            debut, &
+            p1lay, tq_cdrag, precip_rain, precip_snow, &
+            temp_air, spechum, &
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, &
+            radsol, snow, agesno, &
+            qsurf, evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+    END SELECT
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN
+       CALL alboc(FLOAT(jour),rlat,alb_eau)
+    ELSE  ! diurnal cycle
+       CALL alboc_cd(rmu0,alb_eau)
+    ENDIF
+
+    DO i =1, knon
+       alb1_new(i) = alb_eau(knindex(i))
+    ENDDO
+    alb2_new(1:knon) = alb1_new(1:knon)
+
+!****************************************************************************************
+! Calculate the rugosity
+!
+!****************************************************************************************
+    z0_new = SQRT(rugos**2 + rugoro**2)
+
+    ! The rugosity is recalculated with another method
+    z0_new(:) = 0.0
+    DO i = 1, knon
+       z0_new(i) = 0.018*coefm(i) * (u1_lay(i)**2+v1_lay(i)**2)/RG  &
+            +  0.11*14e-6 / SQRT(coefm(i) * (u1_lay(i)**2+v1_lay(i)**2))
+       z0_new(i) = MAX(1.5e-05,z0_new(i))
+    ENDDO
+    
+!
+!****************************************************************************************
+!    
+  END SUBROUTINE surf_ocean
+!
+!****************************************************************************************
+!
+END MODULE surf_ocean_mod
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surf_seaice_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surf_seaice_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surf_seaice_mod.F90	(revision 984)
@@ -0,0 +1,142 @@
+!
+! $Header$
+!
+MODULE surf_seaice_mod
+
+  USE dimphy
+  USE surface_data, ONLY     : ocean
+  USE ocean_slab_mod, ONLY   : ocean_slab_ice
+  USE ocean_forced_mod, ONLY : ocean_forced_ice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_ice
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_seaice( & 
+       rlon, rlat, swnet, lwnet, alb1, fder, &
+       itime, dtime, jour, knon, knindex, &
+       debut, lafin, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       snow, qsurf, qsol, agesno, tsoil, &
+       z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, 
+! slab or couple). The calculation of rugosity for the sea-ice surface is also done
+! in here because it is the same calculation for the different modes of ocean.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: debut, lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet  ! net shortwave radiation at surface  
+    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)        :: fder
+    REAL, DIMENSION(klon), INTENT(IN)        :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsurf, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! Local arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon)  :: radsol
+!
+! End definitions
+!****************************************************************************************
+
+
+!****************************************************************************************
+! Calculate total net radiance at surface
+!
+!****************************************************************************************
+    radsol(:) = 0.0
+    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+!****************************************************************************************
+! Switch according to type of ocean (couple, slab or forced)
+!
+!****************************************************************************************
+    SELECT CASE(ocean)
+    CASE('couple')
+       CALL ocean_cpl_ice( &
+          rlon, rlat, swnet, lwnet, alb1, & 
+          fder, & 
+          itime, dtime, knon, knindex, &
+          lafin,&
+          p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, pctsrf, &
+          radsol, snow, qsurf, &
+          alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+          tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+
+    CASE('slab')
+       CALL ocean_slab_ice( & 
+          itime, dtime, jour, knon, knindex, &
+          debut, &
+          tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, &
+          radsol, snow, qsurf, qsol, agesno, tsoil, &
+          alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+          tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+    
+    CASE('force')
+       CALL ocean_forced_ice(itime, dtime, jour, knon, knindex, &
+          debut, &
+          tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, &
+          radsol, snow, qsol, agesno, tsoil, &
+          qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+          tsurf_new, dflux_s, dflux_l, pctsrf_sic)
+    END SELECT
+
+!****************************************************************************************
+! Calculate rugosity
+!
+!****************************************************************************************
+    z0_new = 0.002
+    z0_new = SQRT(z0_new**2+rugoro**2)
+
+
+  END SUBROUTINE surf_seaice
+!
+!****************************************************************************************
+!
+END MODULE surf_seaice_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/surface_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/surface_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/surface_data.F90	(revision 984)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!
+MODULE surface_data
+
+  USE dimphy, ONLY : klon
+
+  REAL, PARAMETER        :: calice=1.0/(5.1444e+06*0.15)
+  REAL, PARAMETER        :: tau_gl=86400.*5.
+  REAL, PARAMETER        :: calsno=1./(2.3867e+06*.15)
+  
+  LOGICAL, SAVE          :: ok_veget       ! true for use of vegetation model ORCHIDEE
+  !$OMP THREADPRIVATE(ok_veget)
+  CHARACTER(len=6), SAVE :: ocean          ! force/slab/couple
+  !$OMP THREADPRIVATE(ocean)
+
+END MODULE surface_data
Index: LMDZ4/tags/LF_20080728/libf/phylmd/tetalevel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/tetalevel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/tetalevel.F	(revision 984)
@@ -0,0 +1,141 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE tetalevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+c
+cym#include "paramet.h"
+c
+      INTEGER,ALLOCATABLE,SAVE :: lt(:), lb(:)
+      REAL,ALLOCATABLE,SAVE    :: aist(:), aisb(:)
+      REAL,SAVE :: ptop, pbot 
+      LOGICAL,SAVE :: first = .TRUE.
+c$OMP THREADPRIVATE(lt,lb,aist,aisb,ptop, pbot,first)
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+      IF (first) THEN
+        ALLOCATE(lt(ilon), lb(ilon))
+	ALLOCATE(aist(ilon), aisb(ilon))
+	
+	first=.FALSE.
+      ENDIF
+c=====================================================================
+      if (lnew) then
+c   on r�nitialise les r�ndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Fr��ic Hourdin (3/01/02)
+
+c       IF(pgcm(i,lb(i)).NE.0.OR.
+c    $     pgcm(i,lt(i)).NE.0.) THEN
+c
+c       PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+c    .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell.F	(revision 984)
@@ -0,0 +1,1270 @@
+      SUBROUTINE calcul_sec(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev
+     s                  ,pu,pv,pt,po
+     s                  ,zmax,wmax,zw2,lmix
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zw2(klon,klev+1),ztva(klon,klev)
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+!      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+!      integer isplit,nsplit
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+ 
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real zalim(klon)
+      integer lalim(klon)
+      real norme(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical therm
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+!      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec
+      save ncorrec
+      data ncorrec/0/
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+climitation de la valeur du lentr
+c      do ig=1,ngrid
+c         lentr(ig)=min(5,lentr(ig))
+c      enddo
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+cinitialisations
+      do ig=1,ngrid
+         zalim(ig)=0.
+         norme(ig)=0.
+         lalim(ig)=1
+      enddo
+      do k=1,klev-1
+         do ig=1,ngrid
+       zalim(ig)=zalim(ig)+zlev(ig,k)*MAX(0.,(ztv(ig,k)-ztv(ig,k+1))
+     s          /(zlev(ig,k+1)-zlev(ig,k)))
+c     s         *(zlev(ig,k+1)-zlev(ig,k))
+       norme(ig)=norme(ig)+MAX(0.,(ztv(ig,k)-ztv(ig,k+1))
+     s          /(zlev(ig,k+1)-zlev(ig,k)))
+c    s          *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+       enddo
+       do ig=1,ngrid
+          if (norme(ig).gt.1.e-10) then
+             zalim(ig)=max(10.*zalim(ig)/norme(ig),zlev(ig,2))
+c             zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig)))
+          endif
+       enddo
+cdétermination du lalim correspondant
+      do k=1,klev-1
+         do ig=1,ngrid
+      if ((zalim(ig).gt.zlev(ig,k)).and.(zalim(ig).le.zlev(ig,k+1))) 
+     s   then
+         lalim(ig)=k
+      endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.lt.lentr(ig)) then 
+                 entr_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)
+c     s                           *(zlev(ig,l+1)-zlev(ig,l))
+     s                           *sqrt(zlev(ig,l+1))
+cautre def
+c                entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
+            endif
+         enddo
+      enddo
+cnouveau test
+c      if (therm) then
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lalim(ig)
+     s          .and.zalim(ig).gt.1.e-10) then 
+c            if (l.le.lentr(ig)) then 
+c               entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zalim(ig)))**(3./2.)
+c               write(10,*)zlev(ig,l),entr_star(ig,l)
+            endif
+         enddo
+      enddo
+c      endif
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (entr_star_tot(ig).gt.1.e-10) then
+c         do l=1,lentr(ig)
+          do l=1,klev
+cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            entr_star(ig,l)=entr_star(ig,l)/entr_star_tot(ig)
+         enddo
+         endif
+      enddo
+c
+c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+c         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+c         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+            lentr(ig)=1
+            lalim(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+      do ig=1,ngrid
+c      write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
+      enddo
+con stoppe après les calculs de zmax et wmax
+      RETURN
+
+c      print*,'avant fermeture'
+c Fermeture,determination de f
+cAttention! entrainement normalisé ou pas?
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+c             do k=lmin(ig),lalim(ig) 
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))
+c     s            *entr_star_tot(ig)
+ctest
+c             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+     s             *wmax(ig))
+c             endif
+         endif
+         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+c      print*,'apres fermeture'
+con stoppe après la fermeture
+      RETURN
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+con stoppe après le calcul de entr
+c      RETURN
+cCR:test pour entrainer moins que la masse
+c       do ig=1,ngrid
+c          do l=1,lentr(ig)
+c             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+c                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+c     s                       -0.9*masse(ig,l)/ptimestep
+c                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+c             endif
+c          enddo
+c       enddo
+cCR: fin test
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+c                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+cRC
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+c      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+c       if (sorties) then
+c      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+c      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c      print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE fermeture_seche(ngrid,nlay
+     s                ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk
+     s                ,alim_star,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect
+     s                ,zmax,wmax)
+
+      USE dimphy
+      IMPLICIT NONE
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+      INTEGER ngrid,nlay
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+      real zlev(klon,klev+1)
+      real alim_star(klon,klev)
+      real f0(klon)
+      integer lentr(klon)
+      integer lmin(klon)
+      real zmax(klon)
+      real wmax(klon)
+      real nu_min
+      real nu_max
+      real r_aspect
+      real rhobarz(klon,klev+1)
+      REAL zh(klon,klev)
+      real zo(klon,klev)
+      real zpspsk(klon,klev)
+
+      integer ig,l
+
+      real f_star(klon,klev+1)
+      real detr_star(klon,klev)
+      real entr_star(klon,klev)
+      real zw2(klon,klev+1)
+      real linter(klon)
+      integer lmix(klon)
+      integer lmax(klon)
+      real zlevinter(klon)
+      real wa_moy(klon,klev+1)
+      real wmaxa(klon)
+      REAL ztv(klon,klev)
+      REAL ztva(klon,klev)
+      real nu(klon,klev)
+!      real zmax0_sec(klon)
+!      save zmax0_sec
+       REAL, SAVE, ALLOCATABLE :: zmax0_sec(:)
+c$OMP THREADPRIVATE(zmax0_sec)
+      logical, save :: first = .true.
+
+      if (first) then
+        allocate(zmax0_sec(klon))
+        first=.false.
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+      ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+      ztv(ig,l)=ztv(ig,l)*(1.+RETV*zo(ig,l))
+         enddo
+      enddo
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.alim_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=alim_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+cestimation du detrainement a partir de la geometrie du pas precedent
+ctests sur la definition du detr
+             nu(ig,l)=(nu_min+nu_max)/2.
+     s         *(1.-(nu_max-nu_min)/(nu_max+nu_min)
+     s  *tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005)))
+         
+             detr_star(ig,l)=rhobarz(ig,l)
+     s                      *sqrt(zw2(ig,l)) 
+     s                       /(r_aspect*zmax0_sec(ig))*
+c     s                       /(r_aspect*zmax0(ig))*
+     s                      (sqrt(nu(ig,l)*zlev(ig,l+1)
+     s                /sqrt(zw2(ig,l)))
+     s                     -sqrt(nu(ig,l)*zlev(ig,l)
+     s                /sqrt(zw2(ig,l))))
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+         endif
+         entr_star(ig,l)=0.9*detr_star(ig,l)
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+c                 detr_star(ig,l)=0.
+             endif 
+c           print*,'ok detr_star'
+cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+     s                      -detr_star(ig,l)
+ctest sur le signe de f_star
+       if ((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10) then 
+cAM on melange Tl et qt du thermique
+          ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig,l)
+     s                    +alim_star(ig,l))
+     s                    *ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)
+     s                     /(f_star(ig,l+1)+detr_star(ig,l)))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+        endif
+c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+c              print*,'linter=',linter(ig)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c     print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                 print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+cpour le cas ou on prend tjs lmin=1
+c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0_sec(ig)=zmax(ig)
+      enddo
+       
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell.h	(revision 984)
@@ -0,0 +1,9 @@
+      integer iflag_thermals,nsplit_thermals
+      real r_aspect_thermals,l_mix_thermals,tau_thermals
+      integer w2di_thermals,isplit
+      integer iflag_coupl,iflag_clos,iflag_wake
+
+      common/ctherm1/iflag_thermals,nsplit_thermals
+      common/ctherm2/r_aspect_thermals,l_mix_thermals,tau_thermals
+      common/ctherm3/w2di_thermals
+      common/ctherm4/iflag_coupl,iflag_clos,iflag_wake
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_closure.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_closure.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_closure.F90	(revision 984)
@@ -0,0 +1,67 @@
+      SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,zmax_sec,wmax_sec,zmax,wmax,f,lev_out)
+
+!-------------------------------------------------------------------------
+!thermcell_closure: fermeture, determination de f
+!-------------------------------------------------------------------------
+      IMPLICIT NONE
+
+#include "iniprint.h"
+      INTEGER ngrid,nlay
+      INTEGER ig,k       
+      REAL r_aspect,ptimestep
+      integer lev_out                           ! niveau pour les print
+
+      INTEGER lalim(ngrid)
+      REAL alim_star(ngrid,nlay)
+      REAL rho(ngrid,nlay)
+      REAL zlev(ngrid,nlay)
+      REAL zmax(ngrid),zmax_sec(ngrid)
+      REAL wmax(ngrid),wmax_sec(ngrid)
+      real zdenom
+
+      REAL alim_star2(ngrid)
+
+      REAL f(ngrid)
+
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (alim_star(ig,1).LT.1.e-10) then
+            f(ig)=0.
+         else   
+             do k=1,lalim(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
+     &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             zdenom=max(500.,zmax(ig))*r_aspect*alim_star2(ig)
+             if (zdenom<1.e-14) then
+                print*,'ig=',ig
+                print*,'alim_star2',alim_star2(ig)
+                print*,'zmax',zmax(ig)
+                print*,'r_aspect',r_aspect
+                print*,'zdenom',zdenom
+                print*,'alim_star',alim_star(ig,:)
+                print*,'zmax_sec',zmax_sec(ig)
+                print*,'wmax_sec',wmax_sec(ig)
+                stop
+             endif
+             if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then 
+             f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect  &
+     &             *alim_star2(ig))
+!            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
+!    &                     zmax_sec(ig))*wmax_sec(ig))
+             else
+             f(ig)=wmax(ig)/zdenom
+!            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
+!     &                     zmax(ig))*wmax(ig))
+             endif
+         endif
+!         f0(ig)=f(ig)
+      enddo
+      if (prt_level.ge.1) print*,'apres fermeture'
+
+!
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dq.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dq.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dq.F90	(revision 984)
@@ -0,0 +1,169 @@
+      subroutine thermcell_dq(ngrid,nlay,ptimestep,fm,entr,  &
+     &           masse,q,dq,qa,lev_out)
+      implicit none
+
+#include "iniprint.h"
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1)
+
+      real zzm
+
+      integer ig,k
+      real cfl
+
+      real qold(ngrid,nlay)
+      real ztimestep
+      integer niter,iter
+
+
+
+! Calcul du critere CFL pour l'advection dans la subsidence
+      cfl = 0.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzm=masse(ig,k)/ptimestep
+            cfl=max(cfl,fm(ig,k)/zzm)
+            if (entr(ig,k).gt.zzm) then
+               print*,'entr dt > m ',entr(ig,k)*ptimestep,masse(ig,k)
+               stop
+            endif
+         enddo
+      enddo
+
+!IM 090508     print*,'CFL CFL CFL CFL ',cfl
+
+#undef CFL
+#ifdef CFL
+! On subdivise le calcul en niter pas de temps.
+      niter=int(cfl)+1
+#else
+      niter=1
+#endif
+
+      ztimestep=ptimestep/niter
+      qold=q
+
+
+do iter=1,niter
+      if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
+
+!   calcul du detrainement
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+!           print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k)
+!test
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+!               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+!     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+!               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+!               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ztimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
+     &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+! Calcul du flux subsident
+
+      do k=2,nlay
+         do ig=1,ngrid
+#undef centre
+#ifdef centre
+             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+#else
+
+#define plusqueun
+#ifdef plusqueun
+! Schema avec advection sur plus qu'une maille.
+            zzm=masse(ig,k)/ztimestep
+            if (fm(ig,k)>zzm) then
+               wqd(ig,k)=zzm*q(ig,k)+(fm(ig,k)-zzm)*q(ig,k+1)
+            else
+               wqd(ig,k)=fm(ig,k)*q(ig,k)
+            endif
+#else
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+#endif
+#endif
+
+            if (wqd(ig,k).lt.0.) then
+!               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+
+! Calcul des tendances
+      do k=1,nlay
+         do ig=1,ngrid
+            q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)  &
+     &               -wqd(ig,k)+wqd(ig,k+1))  &
+     &               *ztimestep/masse(ig,k)
+!            if (dq(ig,k).lt.0.) then
+!               print*,'dq<0!!!'
+!            endif
+         enddo
+      enddo
+
+
+enddo
+
+
+! Calcul des tendances
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep
+            q(ig,k)=qold(ig,k)
+         enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dry.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dry.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dry.F90	(revision 984)
@@ -0,0 +1,212 @@
+       SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                            lalim,lmin,zmax,wmax,lev_out)
+
+!--------------------------------------------------------------------------
+!thermcell_dry: calcul de zmax et wmax du thermique sec
+!--------------------------------------------------------------------------
+       IMPLICIT NONE
+#include "YOMCST.h"       
+#include "iniprint.h"
+       INTEGER l,ig
+
+       INTEGER ngrid,nlay
+       REAL zlev(ngrid,nlay+1)
+       REAL pphi(ngrid,nlay)
+       REAl ztv(ngrid,nlay)
+       REAL alim_star(ngrid,nlay)
+       INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+       REAL zmax(ngrid)
+       REAL wmax(ngrid)
+
+!variables locales
+       REAL zw2(ngrid,nlay+1)
+       REAL f_star(ngrid,nlay+1)
+       REAL ztva(ngrid,nlay+1)
+       REAL wmaxa(ngrid)
+       REAL wa_moy(ngrid,nlay+1)
+       REAL linter(ngrid),zlevinter(ngrid)
+       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
+
+!initialisations
+       do ig=1,ngrid
+          do l=1,nlay+1
+             zw2(ig,l)=0.
+             wa_moy(ig,l)=0.
+          enddo
+       enddo
+       do ig=1,ngrid
+          do l=1,nlay
+             ztva(ig,l)=ztv(ig,l)
+          enddo
+       enddo
+       do ig=1,ngrid
+          wmax(ig)=0.
+          wmaxa(ig)=0.
+       enddo
+!calcul de la vitesse a partir de la CAPE en melangeant thetav
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A eliminer
+! Ce if complique etait fait pour reperer la premiere couche instable
+! Ici, c'est lmin.
+!
+!       do l=1,nlay-2
+!         do ig=1,ngrid
+!            if (ztv(ig,l).gt.ztv(ig,l+1)  &
+!     &         .and.alim_star(ig,l).gt.1.e-10  &
+!     &         .and.zw2(ig,l).lt.1e-10) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! Calcul des F^*, integrale verticale de E^*
+       f_star(:,1)=0.
+       do l=1,nlay
+          f_star(:,l+1)=f_star(:,l)+alim_star(:,l)
+       enddo
+
+! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise
+       linter(:)=0.
+
+! couche la plus haute concernee par le thermique. 
+       lmax(:)=1
+
+! Le niveau linter est une variable continue qui se trouve dans la couche
+! lmax
+
+       do l=1,nlay-2
+         do ig=1,ngrid
+            if (l.eq.lmin(ig).and.lalim(ig).gt.1) then
+
+!------------------------------------------------------------------------
+!  Calcul de la vitesse en haut de la premiere couche instable.
+!  Premiere couche du panache thermique
+!------------------------------------------------------------------------
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+
+!------------------------------------------------------------------------
+! Tant que la vitesse en bas de la couche et la somme du flux de masse
+! et de l'entrainement (c'est a dire le flux de masse en haut) sont
+! positifs, on calcul
+! 1. le flux de masse en haut  f_star(ig,l+1)
+! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l)
+! 3. la vitesse au carré en haut zw2(ig,l+1)
+!------------------------------------------------------------------------
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  A eliminer : dans cette version, si zw2 est > 0 on a un therique.
+!  et donc, au dessus, f_star(ig,l+1) est forcement suffisamment 
+!  grand puisque on n'a pas de detrainement.
+!  f_star est une fonction croissante.
+!  c'est donc vraiment sur zw2 uniquement qu'il faut faire le test.
+!           else if ((zw2(ig,l).ge.1e-10).and.  &
+!    &               (f_star(ig,l)+alim_star(ig,l).gt.1.e-10)) then
+!              f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+            else if (zw2(ig,l).ge.1e-10) then
+
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l)  &
+     &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+  &
+     &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+! determination de zmax continu par interpolation lineaire
+!------------------------------------------------------------------------
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+!               print*,'On tombe sur le cas particulier de thermcell_dry'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+                lmax(ig)=l
+            endif
+
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmax(ig)=l
+            endif
+
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+       if (prt_level.ge.1) print*,'fin calcul zw2'
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A eliminer :
+! Ce calcul de lmax est fait en meme temps que celui de linter, plus haut
+! Calcul de la couche correspondant a la hauteur du thermique
+!      do ig=1,ngrid
+!         lmax(ig)=lalim(ig)
+!      enddo
+!      do ig=1,ngrid
+!         do l=nlay,lalim(ig)+1,-1
+!            if (zw2(ig,l).le.1.e-10) then
+!               lmax(ig)=l-1
+!            endif
+!         enddo
+!      enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH A eliminer
+! Simplification
+!          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+!     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+!     &    -zlev(ig,lmax(ig)))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          zlevinter(ig)=zlev(ig,lmax(ig)) + &
+     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
+           zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+! Verification que lalim<=lmax
+      do ig=1,ngrid
+         if(lalim(ig)>lmax(ig)) then
+           if ( prt_level > 1 ) THEN
+            print*,'WARNING thermcell_dry ig=',ig,'  lalim=',lalim(ig),'  lmax(ig)=',lmax(ig)
+           endif
+           lmax(ig)=lalim(ig)
+         endif
+      enddo
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dv2.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dv2.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_dv2.F90	(revision 984)
@@ -0,0 +1,154 @@
+      subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse  &
+     &    ,fraca,larga  &
+     &    ,u,v,du,dv,ua,va,lev_out)
+      implicit none
+
+#include "iniprint.h"
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2
+      real wvd(ngrid,nlay+1),wud(ngrid,nlay+1)
+      real gamma0,gamma(ngrid,nlay+1)
+      real ue(ngrid,nlay),ve(ngrid,nlay)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+!   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      print*,'WARNING on initialise gamma(1:ngrid,1)=0.'
+      gamma(1:ngrid,1)=0.
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+!   On itère sur la valeur du coeff de freinage.
+!              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+!IM 060508 beg
+!             if(0.5*(fraca(ig,k+1)+fraca(ig,k)).LT.0.) THEN
+!              print*,'th_dv2 ig k fraca(:,k) fraca(:k+1)', &
+!    &         ig,k,fraca(ig,k),fraca(ig,k+1)
+!             endif
+!             if(larga(ig).EQ.0.) THEN
+!              print*,'th_dv2 ig larga=0.',ig
+!             endif
+              if(larga(ig).GT.0.) THEN
+!IM 060508 end
+               gamma0=masse(ig,k)  &
+     &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )  &
+     &         *0.5/larga(ig)  &
+     &         *1.
+!IM 060508 beg
+              else 
+               if(prt_level.GE.10) print*,'WARNING cas ELSE on initialise gamma0=0.'
+               gamma0=0.
+              endif !(larga(ig).GT.0.) THEN
+!IM 060508 end
+!    s         *0.5
+!              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+!   la première fois on multiplie le coefficient de freinage
+!   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+!   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+!   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+!                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+!IM
+         if(prt_level.GE.10) print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), &
+     &   entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), &
+     &   masse(ig,k)
+!
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)  &
+     &               -wud(ig,k)+wud(ig,k+1))  &
+     &               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)  &
+     &               -wvd(ig,k)+wvd(ig,k+1))  &
+     &               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_env.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_env.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_env.F90	(revision 984)
@@ -0,0 +1,139 @@
+      SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
+
+!--------------------------------------------------------------
+!thermcell_env: calcule les caracteristiques de l environnement
+!necessaires au calcul des proprietes dans le thermique
+!--------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"      
+#include "iniprint.h"
+
+      INTEGER ngrid,nlay
+      REAL po(ngrid,nlay)
+      REAL pt(ngrid,nlay)
+      REAL pu(ngrid,nlay)
+      REAL pv(ngrid,nlay)
+      REAL pplay(ngrid,nlay)
+      REAL pplev(ngrid,nlay+1)
+      integer lev_out                           ! niveau pour les print
+
+      REAL zo(ngrid,nlay)
+      REAL zl(ngrid,nlay)
+      REAL zh(ngrid,nlay)
+      REAL ztv(ngrid,nlay)
+      REAL zthl(ngrid,nlay)
+      REAL zpspsk(ngrid,nlay)
+      REAL zu(ngrid,nlay)
+      REAL zv(ngrid,nlay)
+      REAL zqsat(ngrid,nlay)
+
+      INTEGER ig,l,ll
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef,qsatbef
+      real dqsat_dT,DT,num,denom
+      REAL RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      LOGICAL Zsat
+
+      Zsat=.false.
+      RLvCp = RLVTT/RCPD
+
+!
+! Pr Tprec=Tl calcul de qsat 
+! Si qsat>qT T=Tl, q=qT
+! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+! On cherche DDT < DDT0
+!
+! calcul des caracteristiques de l environnement
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+            zqsat(ig,ll)=0.
+         EndDO
+       EndDO
+!
+!
+!recherche de saturation dans l environnement
+       DO ll=1,nlay
+! les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+            qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll)
+            qsatbef=MIN(0.5,qsatbef)
+            zcor=1./(1.-retv*qsatbef)
+            qsatbef=qsatbef*zcor
+            Zsat = (max(0.,po(ig,ll)-qsatbef) .gt. 1.e-10)
+            if (Zsat) then
+            qlbef=max(0.,po(ig,ll)-qsatbef)
+! si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+! on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (abs(DT).gt.DDT0)
+! il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef=Tbef+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+              qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll)
+              qsatbef=MIN(0.5,qsatbef)
+              zcor=1./(1.-retv*qsatbef)
+              qsatbef=qsatbef*zcor
+! on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef
+!          dqsat_dT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef)
+              dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+              num=-Tbef+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              if (denom.lt.1.e-10) then
+                  print*,'pb denom'
+              endif
+              DT=num/denom
+            enddo
+! on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+!          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+!on ecrit zqsat 
+            zqsat(ig,ll)=qsatbef     
+         EndDO
+       EndDO
+!
+!
+!-----------------------------------------------------------------------
+!   incrementation eventuelle de tendances precedentes:
+!   ---------------------------------------------------
+
+      if (prt_level.ge.1) print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+             zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
+             zu(ig,l)=pu(ig,l)
+             zv(ig,l)=pv(ig,l)
+!attention zh est maintenant le profil de T et plus le profil de theta !
+!
+!   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+!Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))  &
+     &           -zl(ig,l))
+!Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+!            
+1015     CONTINUE
+1010  CONTINUE
+ 
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_flux.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_flux.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_flux.F90	(revision 984)
@@ -0,0 +1,507 @@
+!
+! $Header$
+!
+
+
+      SUBROUTINE thermcell_flux(ngrid,klev,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,zmax,lev_out,lunout1,igout)
+
+
+!---------------------------------------------------------------------------
+!thermcell_flux: deduction des flux
+!---------------------------------------------------------------------------
+
+      IMPLICIT NONE
+#include "iniprint.h"
+      
+      INTEGER ig,l
+      INTEGER ngrid,klev
+      
+      REAL alim_star(ngrid,klev),entr_star(ngrid,klev)
+      REAL detr_star(ngrid,klev)
+      REAL zw2(ngrid,klev+1)
+      REAL zlev(ngrid,klev+1)
+      REAL masse(ngrid,klev)
+      REAL ptimestep
+      REAL rhobarz(ngrid,klev)
+      REAL f(ngrid)
+      INTEGER lmax(ngrid)
+      INTEGER lalim(ngrid)
+      REAL zqla(ngrid,klev)
+      REAL zmax(ngrid)
+
+      integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha
+      integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8
+      
+
+      REAL entr(ngrid,klev),detr(ngrid,klev)
+      REAL fm(ngrid,klev+1)
+      REAL zfm
+
+      integer igout
+      integer lev_out
+      integer lunout1
+
+      REAL f_old,ddd0,eee0,ddd,eee,zzz
+
+      REAL fomass_max,alphamax
+      save fomass_max,alphamax
+
+      fomass_max=0.5
+      alphamax=0.7
+
+      ncorecfm1=0
+      ncorecfm2=0
+      ncorecfm3=0
+      ncorecfm4=0
+      ncorecfm5=0
+      ncorecfm6=0
+      ncorecfm7=0
+      ncorecfm8=0
+      ncorecalpha=0
+
+!initialisation
+      fm(:,:)=0.
+      
+      if (prt_level.ge.10) then
+         write(lunout,*) 'Dans thermcell_flux 0'
+         write(lunout,*) 'flux base ',f(igout)
+         write(lunout,*) 'lmax ',lmax(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) 'ig= ',igout
+         write(lunout,*) ' l E*    A*     D*  '
+         write(lunout,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) &
+     &    ,l=1,lmax(igout))
+      endif
+
+
+!-------------------------------------------------------------------------
+! Verification de la nullite des entrainement et detrainement au dessus
+! de lmax(ig)
+!-------------------------------------------------------------------------
+     if ( prt_level > 1 ) THEN
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+               if (entr_star(ig,l).gt.1.) then
+                    print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+!                   stop
+               endif
+            else
+               if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then
+                    print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+                    stop
+               endif
+            endif
+         enddo
+      enddo
+     endif  !( prt_level > 1 ) THEN
+!-------------------------------------------------------------------------
+! Multiplication par le flux de masse issu de la femreture
+!-------------------------------------------------------------------------
+
+      do l=1,klev
+         entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l))
+         detr(:,l)=f(:)*detr_star(:,l)
+      enddo
+
+      if (prt_level.ge.10) then
+         write(lunout,*) 'Dans thermcell_flux 1'
+         write(lunout,*) 'flux base ',f(igout)
+         write(lunout,*) 'lmax ',lmax(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) 'ig= ',igout
+         write(lunout,*) ' l   E    D     W2'
+         write(lunout,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) &
+     &    ,zw2(igout,l+1),l=1,lmax(igout))
+      endif
+
+      fm(:,1)=0.
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+      enddo
+
+
+
+! Test provisoire : pour comprendre pourquoi on corrige plein de fois 
+! le cas fm6, on commence par regarder une premiere fois avant les
+! autres corrections.
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm8=ncorecfm8+1
+!              igout=ig
+            endif
+         enddo
+      enddo
+
+      if (prt_level.ge.10) &
+    &    call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,'2  ')
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Version en cours de test;
+! par rapport a thermcell_flux, on fait une grande boucle sur "l"
+! et on modifie le flux avec tous les contrôles appliques d'affilee
+! pour la meme couche
+! Momentanement, on duplique le calcule du flux pour pouvoir comparer
+! les flux avant et apres modif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do l=1,klev
+
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+
+
+!-------------------------------------------------------------------------
+! Verification de la positivite des flux de masse
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+!              print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1)
+                ncorecfm1=ncorecfm1+1
+               fm(ig,l+1)=fm(ig,l)
+               detr(ig,l)=entr(ig,l)
+            endif
+         enddo
+!     enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!Test sur fraca croissant
+!-------------------------------------------------------------------------
+
+
+      if (1.eq.1) then
+!     do l=1,klev
+         do ig=1,ngrid
+          if (l.ge.lalim(ig).and.l.le.lmax(ig) &
+     &    .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then
+!  zzz est le flux en l+1 a frac constant
+             zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)  &
+     &                          /(rhobarz(ig,l)*zw2(ig,l))
+             if (fm(ig,l+1).gt.zzz) then
+                detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz
+                fm(ig,l+1)=zzz
+                ncorecfm4=ncorecfm4+1
+             endif
+          endif
+        enddo
+!     enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+      else
+       if (l.eq.1) then
+         print*,'Test sur les fractions croissantes inhibe dans thermcell_flux2'
+       endif
+      endif
+
+
+!-------------------------------------------------------------------------
+!test sur flux de masse croissant
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=fm(ig,l)
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+               ncorecfm5=ncorecfm5+1
+            endif
+         enddo
+!     enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!detr ne peut pas etre superieur a fm
+!-------------------------------------------------------------------------
+
+      if(1.eq.1) then
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (entr(ig,l)<0.) then
+               print*,'N1 ig,l,entr',ig,l,entr(ig,l)
+               stop'entr negatif'
+            endif
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm6=ncorecfm6+1
+               detr(ig,l)=fm(ig,l)
+!              entr(ig,l)=fm(ig,l+1)
+
+! Dans le cas ou on est au dessus de la couche d'alimentation et que le
+! detrainement est plus fort que le flux de masse, on stope le thermique.
+               if (l.gt.lalim(ig)) then
+                  lmax(ig)=l
+                  fm(ig,l+1)=0.
+                  entr(ig,l)=0.
+               else
+                  ncorecfm7=ncorecfm7+1
+               endif
+            endif
+
+            if(l.gt.lmax(ig)) then
+               detr(ig,l)=0.
+               fm(ig,l+1)=0.
+               entr(ig,l)=0.
+            endif
+
+            if (entr(ig,l).lt.0.) then
+               print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'entr(ig,l)',entr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               stop'probleme dans thermcell flux'
+            endif
+         enddo
+!     enddo
+      endif
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!fm ne peut pas etre negatif
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
+               fm(ig,l+1)=0.
+!              print*,'fm2<0',l+1,lmax(ig)
+               ncorecfm2=ncorecfm2+1
+            endif
+            if (detr(ig,l).lt.0.) then
+               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'detr(ig,l)',detr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               stop'probleme dans thermcell flux'
+            endif
+        enddo
+!    enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-----------------------------------------------------------------------
+!la fraction couverte ne peut pas etre superieure a 1            
+!-----------------------------------------------------------------------
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Partie a revisiter.
+! Il semble qu'etaient codees ici deux optiques dans le cas
+! F/ (rho *w) > 1
+! soit limiter la hauteur du thermique en considerant que c'est 
+! la derniere chouche, soit limiter F a rho w.
+! Dans le second cas, il faut en fait limiter a un peu moins
+! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin
+! dans thermcell_main et qu'il semble de toutes facons deraisonable
+! d'avoir des fractions de 1..
+! Ci dessous, et dans l'etat actuel, le premier des  deux if est
+! sans doute inutile.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    do l=1,klev
+        do ig=1,ngrid
+           if (zw2(ig,l+1).gt.1.e-10) then
+           zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax
+           if ( fm(ig,l+1) .gt. zfm) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=zfm
+!             zw2(ig,l+1)=0.
+!             zqla(ig,l+1)=0.
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+!             lmax(ig)=l+1
+!             zmax(ig)=zlev(ig,lmax(ig))
+!             print*,'alpha>1',l+1,lmax(ig)
+              ncorecalpha=ncorecalpha+1
+           endif
+           endif
+        enddo
+!    enddo
+!
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+! Fin de la grande boucle sur les niveaux verticaux
+      enddo
+
+      if (prt_level.ge.10) &
+    &    call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,'8  ')
+
+
+!-----------------------------------------------------------------------
+! On fait en sorte que la quantite totale d'air entraine dans le 
+! panache ne soit pas trop grande comparee a la masse de la maille
+!-----------------------------------------------------------------------
+
+      if (1.eq.1) then
+      do l=1,klev-1
+         do ig=1,ngrid
+            eee0=entr(ig,l)
+            ddd0=detr(ig,l)
+            eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep
+            ddd=detr(ig,l)-eee
+            if (eee.gt.0.) then
+                ncorecfm3=ncorecfm3+1
+                entr(ig,l)=entr(ig,l)-eee
+                if ( ddd.gt.0.) then
+!   l'entrainement est trop fort mais l'exces peut etre compense par une
+!   diminution du detrainement)
+                   detr(ig,l)=ddd
+                else
+!   l'entrainement est trop fort mais l'exces doit etre compense en partie
+!   par un entrainement plus fort dans la couche superieure
+                   if(l.eq.lmax(ig)) then
+                      detr(ig,l)=fm(ig,l)+entr(ig,l)
+                   else
+                      if(l.ge.lmax(ig).and.0.eq.1) then
+                         print*,'ig,l',ig,l
+                         print*,'eee0',eee0
+                         print*,'ddd0',ddd0
+                         print*,'eee',eee
+                         print*,'ddd',ddd
+                         print*,'entr',entr(ig,l)
+                         print*,'detr',detr(ig,l)
+                         print*,'masse',masse(ig,l)
+                         print*,'fomass_max',fomass_max
+                         print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep
+                         print*,'ptimestep',ptimestep
+                         print*,'lmax(ig)',lmax(ig)
+                         print*,'fm(ig,l+1)',fm(ig,l+1)
+                         print*,'fm(ig,l)',fm(ig,l)
+                         stop'probleme dans thermcell_flux'
+                      endif
+                      entr(ig,l+1)=entr(ig,l+1)-ddd
+                      detr(ig,l)=0.
+                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                      detr(ig,l)=0.
+                   endif
+                endif
+            endif
+         enddo
+      enddo
+      endif
+!                  
+!              ddd=detr(ig)-entre
+!on s assure que tout s annule bien en zmax
+      do ig=1,ngrid
+         fm(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig))
+      enddo
+
+!-----------------------------------------------------------------------
+! Impression du nombre de bidouilles qui ont ete necessaires
+!-----------------------------------------------------------------------
+
+      if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then
+       if (prt_level.ge.10) then
+          print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',&
+    &     ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', &
+    &     ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', &
+    &     ncorecfm6,'x fm6', &
+    &     ncorecfm7,'x fm7', &
+    &     ncorecfm8,'x fm8', &
+    &     ncorecalpha,'x alpha'
+       endif
+      endif
+
+      if (prt_level.ge.10) &
+    &    call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,'fin')
+
+
+      return
+      end
+
+      subroutine printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,descr)
+
+     implicit none
+
+      integer ngrid,klev,lunout,igout,l,lm
+
+      integer lmax(klev),lalim(klev)
+      real ptimestep,masse(ngrid,klev),entr(ngrid,klev),detr(ngrid,klev)
+      real fm(ngrid,klev+1),f(ngrid)
+
+      character*3 descr
+
+      lm=lmax(igout)+5
+      if(lm.gt.klev) lm=klev
+
+      print*,'Impression jusque lm=',lm
+
+         write(lunout,*) 'Dans thermcell_flux '//descr
+         write(lunout,*) 'flux base ',f(igout)
+         write(lunout,*) 'lmax ',lmax(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) 'ig= ',igout
+         write(lunout,'(a3,4a14)') 'l','M','E','D','F'
+         write(lunout,'(i4,4e14.4)') (l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l) &
+     &    ,fm(igout,l+1),l=1,lm)
+
+
+      do l=lmax(igout)+1,klev
+          if (abs(entr(igout,l))+abs(detr(igout,l))+abs(fm(igout,l)).gt.0.) then
+          print*,'cas 1 : igout,l,lmax(igout)',igout,l,lmax(igout)
+          print*,'entr(igout,l)',entr(igout,l)
+          print*,'detr(igout,l)',detr(igout,l)
+          print*,'fm(igout,l)',fm(igout,l)
+          stop
+          endif
+      enddo
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_flux2.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_flux2.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_flux2.F90	(revision 984)
@@ -0,0 +1,458 @@
+      SUBROUTINE thermcell_flux2(ngrid,klev,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,lev_out,lunout1,igout)
+!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
+
+
+!---------------------------------------------------------------------------
+!thermcell_flux: deduction des flux
+!---------------------------------------------------------------------------
+
+      IMPLICIT NONE
+#include "iniprint.h"
+      
+      INTEGER ig,l
+      INTEGER ngrid,klev
+      
+      REAL alim_star(ngrid,klev),entr_star(ngrid,klev)
+      REAL detr_star(ngrid,klev)
+      REAL zw2(ngrid,klev+1)
+      REAL zlev(ngrid,klev+1)
+      REAL masse(ngrid,klev)
+      REAL ptimestep
+      REAL rhobarz(ngrid,klev)
+      REAL f(ngrid)
+      INTEGER lmax(ngrid)
+      INTEGER lalim(ngrid)
+      REAL zqla(ngrid,klev)
+      REAL zmax(ngrid)
+
+      integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha
+      integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8
+      
+
+      REAL entr(ngrid,klev),detr(ngrid,klev)
+      REAL fm(ngrid,klev+1)
+      REAL zfm
+
+      integer igout
+      integer lev_out
+      integer lunout1
+
+      REAL f_old,ddd0,eee0,ddd,eee,zzz
+
+      REAL fomass_max,alphamax
+      save fomass_max,alphamax
+
+      fomass_max=0.5
+      alphamax=0.7
+
+      ncorecfm1=0
+      ncorecfm2=0
+      ncorecfm3=0
+      ncorecfm4=0
+      ncorecfm5=0
+      ncorecfm6=0
+      ncorecfm7=0
+      ncorecfm8=0
+      ncorecalpha=0
+
+!initialisation
+      fm(:,:)=0.
+      
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_flux 0'
+         write(lunout1,*) 'flux base ',f(igout)
+         write(lunout1,*) 'lmax ',lmax(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) 'ig= ',igout
+         write(lunout1,*) ' l E*    A*     D*  '
+         write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) &
+     &    ,l=1,lmax(igout))
+      endif
+
+
+!-------------------------------------------------------------------------
+! Verification de la nullite des entrainement et detrainement au dessus
+! de lmax(ig)
+!-------------------------------------------------------------------------
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+               if (entr_star(ig,l).gt.1.) then
+                    print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+!                   stop
+               endif
+            else
+               if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then
+                    print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+                    stop
+               endif
+            endif
+         enddo
+      enddo
+
+!-------------------------------------------------------------------------
+! Multiplication par le flux de masse issu de la femreture
+!-------------------------------------------------------------------------
+
+      do l=1,klev
+         entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l))
+         detr(:,l)=f(:)*detr_star(:,l)
+      enddo
+
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_flux 1'
+         write(lunout1,*) 'flux base ',f(igout)
+         write(lunout1,*) 'lmax ',lmax(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) 'ig= ',igout
+         write(lunout1,*) ' l   E    D     W2'
+         write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) &
+     &    ,zw2(igout,l+1),l=1,lmax(igout))
+      endif
+
+      fm(:,1)=0.
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+      enddo
+
+
+
+! Test provisoire : pour comprendre pourquoi on corrige plein de fois 
+! le cas fm6, on commence par regarder une premiere fois avant les
+! autres corrections.
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm8=ncorecfm8+1
+!              igout=ig
+            endif
+         enddo
+      enddo
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'2  ')
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Version en cours de test;
+! par rapport a thermcell_flux, on fait une grande boucle sur "l"
+! et on modifie le flux avec tous les contrôles appliques d'affilee
+! pour la meme couche
+! Momentanement, on duplique le calcule du flux pour pouvoir comparer
+! les flux avant et apres modif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do l=1,klev
+
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+
+
+!-------------------------------------------------------------------------
+! Verification de la positivite des flux de masse
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+!              print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1)
+                ncorecfm1=ncorecfm1+1
+               fm(ig,l+1)=fm(ig,l)
+               detr(ig,l)=entr(ig,l)
+            endif
+         enddo
+!     enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!Test sur fraca croissant
+!-------------------------------------------------------------------------
+      if (1.eq.1) then 
+!     do l=1,klev
+         do ig=1,ngrid
+          if (l.ge.lalim(ig).and.l.le.lmax(ig) &
+     &    .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then
+!  zzz est le flux en l+1 a frac constant
+             zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)  &
+     &                          /(rhobarz(ig,l)*zw2(ig,l))
+             if (fm(ig,l+1).gt.zzz) then
+                detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz
+                fm(ig,l+1)=zzz
+                ncorecfm4=ncorecfm4+1
+             endif
+          endif
+        enddo
+!     enddo
+      endif
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+
+!-------------------------------------------------------------------------
+!test sur flux de masse croissant
+!-------------------------------------------------------------------------
+      if (1.eq.1) then
+!     do l=1,klev
+         do ig=1,ngrid
+            if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=fm(ig,l)
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+               ncorecfm5=ncorecfm5+1
+            endif
+         enddo
+!     enddo
+      endif
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!fin 1.eq.0
+!-------------------------------------------------------------------------
+!detr ne peut pas etre superieur a fm
+!-------------------------------------------------------------------------
+
+      if(1.eq.1) then
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (entr(ig,l)<0.) then
+               print*,'N1 ig,l,entr',ig,l,entr(ig,l)
+               stop'entr negatif'
+            endif
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm6=ncorecfm6+1
+               detr(ig,l)=fm(ig,l)
+               entr(ig,l)=fm(ig,l+1)
+
+! Dans le cas ou on est au dessus de la couche d'alimentation et que le
+! detrainement est plus fort que le flux de masse, on stope le thermique.
+!test:on commente
+!               if (l.gt.lalim(ig)) then
+!                  lmax(ig)=l
+!                  fm(ig,l+1)=0.
+!                  entr(ig,l)=0.
+!               else
+!                  ncorecfm7=ncorecfm7+1
+!               endif
+            endif
+
+            if(l.gt.lmax(ig)) then
+               detr(ig,l)=0.
+               fm(ig,l+1)=0.
+               entr(ig,l)=0.
+            endif
+
+            if (entr(ig,l).lt.0.) then
+               print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'entr(ig,l)',entr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               stop'probleme dans thermcell flux'
+            endif
+         enddo
+!     enddo
+      endif
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!fm ne peut pas etre negatif
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
+               fm(ig,l+1)=0.
+!              print*,'fm2<0',l+1,lmax(ig)
+               ncorecfm2=ncorecfm2+1
+            endif
+            if (detr(ig,l).lt.0.) then
+               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'detr(ig,l)',detr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               stop'probleme dans thermcell flux'
+            endif
+        enddo
+!    enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-----------------------------------------------------------------------
+!la fraction couverte ne peut pas etre superieure a 1            
+!-----------------------------------------------------------------------
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Partie a revisiter.
+! Il semble qu'etaient codees ici deux optiques dans le cas
+! F/ (rho *w) > 1
+! soit limiter la hauteur du thermique en considerant que c'est 
+! la derniere chouche, soit limiter F a rho w.
+! Dans le second cas, il faut en fait limiter a un peu moins
+! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin
+! dans thermcell_main et qu'il semble de toutes facons deraisonable
+! d'avoir des fractions de 1..
+! Ci dessous, et dans l'etat actuel, le premier des  deux if est
+! sans doute inutile.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    do l=1,klev
+        do ig=1,ngrid
+           if (zw2(ig,l+1).gt.1.e-10) then
+           zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax
+           if ( fm(ig,l+1) .gt. zfm) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=zfm
+!             zw2(ig,l+1)=0.
+!             zqla(ig,l+1)=0.
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+!             lmax(ig)=l+1
+!             zmax(ig)=zlev(ig,lmax(ig))
+!             print*,'alpha>1',l+1,lmax(ig)
+              ncorecalpha=ncorecalpha+1
+           endif
+           endif
+        enddo
+!    enddo
+!
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+! Fin de la grande boucle sur les niveaux verticaux
+      enddo
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'8  ')
+
+
+!-----------------------------------------------------------------------
+! On fait en sorte que la quantite totale d'air entraine dans le 
+! panache ne soit pas trop grande comparee a la masse de la maille
+!-----------------------------------------------------------------------
+
+      if (1.eq.1) then
+      do l=1,klev-1
+         do ig=1,ngrid
+            eee0=entr(ig,l)
+            ddd0=detr(ig,l)
+            eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep
+            ddd=detr(ig,l)-eee
+            if (eee.gt.0.) then
+                ncorecfm3=ncorecfm3+1
+                entr(ig,l)=entr(ig,l)-eee
+                if ( ddd.gt.0.) then
+!   l'entrainement est trop fort mais l'exces peut etre compense par une
+!   diminution du detrainement)
+                   detr(ig,l)=ddd
+                else
+!   l'entrainement est trop fort mais l'exces doit etre compense en partie
+!   par un entrainement plus fort dans la couche superieure
+                   if(l.eq.lmax(ig)) then
+                      detr(ig,l)=fm(ig,l)+entr(ig,l)
+                   else
+                      if(l.ge.lmax(ig).and.0.eq.1) then
+                         print*,'ig,l',ig,l
+                         print*,'eee0',eee0
+                         print*,'ddd0',ddd0
+                         print*,'eee',eee
+                         print*,'ddd',ddd
+                         print*,'entr',entr(ig,l)
+                         print*,'detr',detr(ig,l)
+                         print*,'masse',masse(ig,l)
+                         print*,'fomass_max',fomass_max
+                         print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep
+                         print*,'ptimestep',ptimestep
+                         print*,'lmax(ig)',lmax(ig)
+                         print*,'fm(ig,l+1)',fm(ig,l+1)
+                         print*,'fm(ig,l)',fm(ig,l)
+                         stop'probleme dans thermcell_flux'
+                      endif
+                      entr(ig,l+1)=entr(ig,l+1)-ddd
+                      detr(ig,l)=0.
+                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                      detr(ig,l)=0.
+                   endif
+                endif
+            endif
+         enddo
+      enddo
+      endif
+!                  
+!              ddd=detr(ig)-entre
+!on s assure que tout s annule bien en zmax
+      do ig=1,ngrid
+         fm(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig))
+      enddo
+
+!-----------------------------------------------------------------------
+! Impression du nombre de bidouilles qui ont ete necessaires
+!-----------------------------------------------------------------------
+
+!IM 090508 beg
+!     if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then
+!
+!         print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',&
+!   &     ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', &
+!   &     ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', &
+!   &     ncorecfm6,'x fm6', &
+!   &     ncorecfm7,'x fm7', &
+!   &     ncorecfm8,'x fm8', &
+!   &     ncorecalpha,'x alpha'
+!     endif
+!IM 090508 end
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'fin')
+
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_height.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_height.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_height.F90	(revision 984)
@@ -0,0 +1,126 @@
+      SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,  &
+     &           zw2,zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)                            
+
+!-----------------------------------------------------------------------------
+!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix
+!-----------------------------------------------------------------------------
+      IMPLICIT NONE
+#include "iniprint.h"
+
+      INTEGER ig,l
+      INTEGER ngrid,nlay
+      INTEGER lalim(ngrid),lmin(ngrid)
+      INTEGER lmix(ngrid)
+      REAL linter(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+      REAL zw2(ngrid,nlay+1)
+      REAL zlev(ngrid,nlay+1)
+
+      REAL wmax(ngrid)
+      INTEGER lmax(ngrid)
+      REAL zmax(ngrid)
+      REAL zmax0(ngrid)
+      REAL zmix(ngrid)
+
+      REAL zlevinter(ngrid)
+
+!calcul de la hauteur max du thermique
+      do ig=1,ngrid
+         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+             lmax(ig)=1
+             lmin(ig)=1
+             lalim(ig)=1
+         endif
+      enddo 
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+     &    -zlev(ig,lmax(ig)))
+!pour le cas ou on prend tjs lmin=1
+!       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+      enddo
+!
+! def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1) then
+! test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)  &
+     &        then
+!             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))  &
+     &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+!test
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+!            print*,'pb zmix>zmax'
+         endif
+      enddo
+!
+! calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,nlay
+            if (zmix(ig).ge.zlev(ig,l).and.  &
+     &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_init.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_init.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_init.F90	(revision 984)
@@ -0,0 +1,134 @@
+      SUBROUTINE thermcell_init(ngrid,nlay,ztv,zlay,zlev,  &
+     &                  lalim,lmin,alim_star,alim_star_tot,lev_out)
+
+!----------------------------------------------------------------------
+!thermcell_init: calcul du profil d alimentation du thermique
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+#include "iniprint.h"
+
+      INTEGER l,ig
+!arguments d entree
+      INTEGER ngrid,nlay
+      REAL ztv(ngrid,nlay)
+      REAL zlay(ngrid,nlay)
+      REAL zlev(ngrid,nlay+1)
+!arguments de sortie
+      INTEGER lalim(ngrid)
+      INTEGER lmin(ngrid)
+      REAL alim_star(ngrid,nlay)
+      REAL alim_star_tot(ngrid)
+      integer lev_out                           ! niveau pour les print
+      
+      REAL zzalim(ngrid)
+!CR: ponderation entrainement des couches instables
+!def des alim_star tels que alim=f*alim_star      
+
+      do l=1,nlay
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+         enddo
+      enddo
+! determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lalim(ig)=1
+      enddo
+
+!on ne considere que les premieres couches instables
+      do l=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          ztv(ig,l+1).le.ztv(ig,l+2)) then
+               lalim(ig)=l+1
+            endif
+          enddo
+      enddo
+
+! determination du lmin: couche d ou provient le thermique
+
+      do ig=1,ngrid
+! FH initialisation de lmin a nlay plutot que 1.
+!        lmin(ig)=nlay
+         lmin(ig)=1
+      enddo
+      do l=nlay,2,-1
+         do ig=1,ngrid
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!
+      zzalim(:)=0.
+      do l=1,nlay-1
+         do ig=1,ngrid 
+             if (l<lalim(ig)) then
+                zzalim(ig)=zzalim(ig)+zlay(ig,l)*(ztv(ig,l)-ztv(ig,l+1))
+             endif
+          enddo
+      enddo
+      do ig=1,ngrid
+          if (lalim(ig)>1) then
+             zzalim(ig)=zlay(ig,1)+zzalim(ig)/(ztv(ig,1)-ztv(ig,lalim(ig)))
+          else
+             zzalim(ig)=zlay(ig,1)
+          endif
+      enddo
+
+      if(prt_level.GE.10) print*,'ZZALIM LALIM ',zzalim,lalim,zlay(1,lalim(1))
+
+! definition de l'entrainement des couches
+      if (1.eq.1) then
+      do l=1,nlay-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
+!def possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
+     &                       *sqrt(zlev(ig,l+1)) 
+            endif
+         enddo
+      enddo
+      else
+      do l=1,nlay-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
+             alim_star(ig,l)=max(3.*zzalim(ig)-zlay(ig,l),0.) &
+     &        *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+      endif
+      
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+!CRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,nlay
+                alim_star(ig,l)=0.
+            enddo
+            lmin(ig)=1
+         endif
+      enddo 
+! calcul de l alimentation totale
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+         enddo
+      enddo
+!
+! Calcul entrainement normalise
+      do l=1,nlay 
+         do ig=1,ngrid 
+            if (alim_star_tot(ig).gt.1.e-10) then
+               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+            endif
+         enddo
+      enddo
+       
+      return 
+      end  
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_main.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_main.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_main.F90	(revision 984)
@@ -0,0 +1,817 @@
+!
+! $Header$
+!
+      SUBROUTINE thermcell_main(itap,ngrid,nlay,ptimestep  &
+     &                  ,pplay,pplev,pphi,debut  &
+     &                  ,pu,pv,pt,po  &
+     &                  ,pduadj,pdvadj,pdtadj,pdoadj  &
+     &                  ,fm0,entr0,detr0,zqla,lmax  &
+     &                  ,ratqscth,ratqsdiff,zqsatth  &
+     &                  ,r_aspect,l_mix,tau_thermals &
+     &                  ,Ale_bl,Alp_bl,lalim_conv,wght_th &
+     &                  ,zmax0, f0)
+
+      USE dimphy
+      IMPLICIT NONE
+
+!=======================================================================
+!   Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu
+!   Version du 09.02.07
+!   Calcul du transport vertical dans la couche limite en presence
+!   de "thermiques" explicitement representes avec processus nuageux
+!
+!   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!
+!   le thermique est supposé homogène et dissipé par mélange avec
+!   son environnement. la longueur l_mix contrôle l'efficacité du
+!   mélange
+!
+!   Le calcul du transport des différentes espèces se fait en prenant
+!   en compte:
+!     1. un flux de masse montant
+!     2. un flux de masse descendant
+!     3. un entrainement
+!     4. un detrainement
+!
+!=======================================================================
+
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+
+#include "dimensions.h"
+!#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+
+!   arguments:
+!   ----------
+
+!IM 140508
+      INTEGER itap
+
+      INTEGER ngrid,nlay,w2di
+      real tau_thermals
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+!   local:
+!   ------
+
+      integer icount
+      data icount/0/
+      save icount
+
+      integer,save :: igout=1
+      integer,save :: lunout1=6
+      integer,save :: lev_out=10
+
+      INTEGER ig,k,l,ll
+      real zsortie1d(klon)
+      INTEGER lmax(klon),lmin(klon),lalim(klon)
+      INTEGER lmix(klon)
+      real linter(klon)
+      real zmix(klon)
+      real zmax(klon),zw2(klon,klev+1),ztva(klon,klev)
+      real zmax_sec(klon)
+      real w_est(klon,klev+1)
+!on garde le zmax du pas de temps precedent
+      real zmax0(klon)
+!FH/IM     save zmax0
+
+      real lambda
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real fraca(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+! FH probleme de dimensionnement avec l'allocation dynamique
+!     common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real var
+      real vardiff
+      real ratqsdiff(klon,klev)
+      integer isplit,nsplit
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon)
+      real wmax_sec(klon)
+      real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev),detr(klon,klev)
+
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+!niveau de condensation
+      integer nivcon(klon)
+      real zcon(klon)
+      REAL CHI
+      real zcon2(klon)
+      real pcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real alim_star(klon,klev)
+      real f(klon), f0(klon)
+!FH/IM     save f0
+      real zlevinter(klon)
+      logical debut
+       real seuil
+
+!
+      !nouvelles variables pour la convection
+      real Ale_bl(klon)
+      real Alp_bl(klon)
+      real alp_int(klon)
+      real ale_int(klon)
+      integer n_int(klon)
+      real fm_tot(klon)
+      real wght_th(klon,klev)
+      integer lalim_conv(klon)
+!v1d     logical therm
+!v1d     save therm
+
+      character*2 str2
+      character*10 str10
+
+      EXTERNAL SCOPY
+!
+
+!-----------------------------------------------------------------------
+!   initialisation:
+!   ---------------
+!
+
+      seuil=0.25
+
+      if (debut)  then
+         fm0=0.
+         entr0=0.
+         detr0=0.
+      endif
+
+      fm=0. ; entr=0. ; detr=0.
+
+      icount=icount+1
+
+!IM 090508 beg
+!print*,'====================================================================='
+!print*,'====================================================================='
+!print*,' PAS ',icount,' PAS ',icount,' PAS ',icount,' PAS ',icount
+!print*,'====================================================================='
+!print*,'====================================================================='
+!IM 090508 end
+
+      if (prt_level.ge.1) print*,'thermcell_main V4'
+
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!
+!Initialisation
+!
+!    IF (1.eq.0) THEN
+!     do ig=1,klon      
+!FH/IM 130308     if ((debut).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
+!     if ((.not.debut).and.(f0(ig).lt.1.e-10)) then
+!           f0(ig)=1.e-5
+!           zmax0(ig)=40.
+!v1d        therm=.false.
+!     endif
+!     enddo 
+!    ENDIF !(1.eq.0) THEN
+     print*,'WARNING thermcell_main f0=max(f0,1.e-2)'
+     do ig=1,klon
+      if (prt_level.ge.20) then
+       print*,'th_main ig f0',ig,f0(ig)
+      endif
+         f0(ig)=max(f0(ig),1.e-2)
+!IMmarche pas ?!       if (f0(ig)<1.e-2) f0(ig)=1.e-2
+     enddo
+
+!-----------------------------------------------------------------------
+! Calcul de T,q,ql a partir de Tl et qT dans l environnement
+!   --------------------------------------------------------------------
+!
+      CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
+       
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env'
+
+!------------------------------------------------------------------------
+!                       --------------------
+!
+!
+!                       + + + + + + + + + + +
+!
+!
+!  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!  wh,wt,wo ...
+!
+!                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!
+!
+!                       --------------------   zlev(1)
+!                       \\\\\\\\\\\\\\\\\\\\
+!
+!
+
+!-----------------------------------------------------------------------
+!   Calcul des altitudes des couches
+!-----------------------------------------------------------------------
+
+      do l=2,nlay
+         zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG
+      enddo
+         zlev(:,1)=0.
+         zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG
+      do l=1,nlay
+         zlay(:,l)=pphi(:,l)/RG
+      enddo
+!calcul de l epaisseur des couches
+      do l=1,nlay
+         deltaz(:,l)=zlev(:,l+1)-zlev(:,l)
+      enddo
+
+!     print*,'2 OK convect8'
+!-----------------------------------------------------------------------
+!   Calcul des densites
+!-----------------------------------------------------------------------
+
+      do l=1,nlay
+         rho(:,l)=pplay(:,l)/(zpspsk(:,l)*RD*ztv(:,l))
+      enddo
+
+!IM
+      print*,'WARNING thermcell_main rhobarz(:,1)=rho(:,1)'
+      rhobarz(:,1)=rho(:,1)
+
+      do l=2,nlay
+         rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1))
+      enddo
+
+!calcul de la masse
+      do l=1,nlay
+         masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG
+      enddo
+
+      if (prt_level.ge.1) print*,'thermcell_main apres initialisation'
+
+!------------------------------------------------------------------
+!
+!             /|\
+!    --------  |  F_k+1 -------   
+!                              ----> D_k
+!             /|\              <---- E_k , A_k
+!    --------  |  F_k --------- 
+!                              ----> D_k-1
+!                              <---- E_k-1 , A_k-1
+!
+!
+!
+!
+!
+!    ---------------------------
+!
+!    ----- F_lmax+1=0 ----------         \
+!            lmax     (zmax)              |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |  E
+!    ---------------------------          |  D
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------  \       |
+!            lalim                 |      |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!                                  | A    |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!    lmin  (=1 pour le moment)     |      |
+!    ----- F_lmin=0 ------------  /      /
+!
+!    ---------------------------
+!    //////////////////////////
+!
+!
+!=============================================================================
+!  Calculs initiaux ne faisant pas intervenir les changements de phase
+!=============================================================================
+
+!------------------------------------------------------------------
+!  1. alim_star est le profil vertical de l'alimentation à la base du
+!     panache thermique, calculé à partir de la flotabilité de l'air sec
+!  2. lmin et lalim sont les indices inferieurs et superieurs de alim_star
+!------------------------------------------------------------------
+!
+      entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0.
+      CALL thermcell_init(ngrid,nlay,ztv,zlay,zlev,  &
+     &                    lalim,lmin,alim_star,alim_star_tot,lev_out)
+
+call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lmin  ')
+call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lalim ')
+
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_init'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 1'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star thetav'
+         write(lunout1,'(i6,i4,2e15.5)') (igout,l,alim_star(igout,l) &
+     &   ,ztv(igout,l),l=1,lalim(igout)+4)
+      endif
+
+!v1d      do ig=1,klon
+!v1d     if (alim_star(ig,1).gt.1.e-10) then
+!v1d     therm=.true.
+!v1d     endif
+!v1d      enddo
+!-----------------------------------------------------------------------------
+!  3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un
+!     panache sec conservatif (e=d=0) alimente selon alim_star 
+!     Il s'agit d'un calcul de type CAPE
+!     zmax_sec est utilisé pour déterminer la géométrie du thermique.
+!------------------------------------------------------------------------------
+!
+      CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
+
+call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
+call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 1b'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) &
+     &    ,l=1,lalim(igout)+4)
+      endif
+
+
+
+!---------------------------------------------------------------------------------
+!calcul du melange et des variables dans le thermique
+!--------------------------------------------------------------------------------
+!
+      if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
+!IM 140508   CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+      CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,  &
+     &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,zqsatth,lmix,linter,lev_out)
+      if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out
+
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 2'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
+     &    ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
+      endif
+
+!-------------------------------------------------------------------------------
+! Calcul des caracteristiques du thermique:zmax,zmix,wmax
+!-------------------------------------------------------------------------------
+!
+      CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2,  &
+     &           zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)
+
+
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height'
+
+!-------------------------------------------------------------------------------
+! Fermeture,determination de f
+!-------------------------------------------------------------------------------
+
+      CALL thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,zmax_sec,wmax_sec,zmax,wmax,f,lev_out)
+
+      if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure'
+
+      if (tau_thermals>1.) then
+         lambda=exp(-ptimestep/tau_thermals)
+         f0=(1.-lambda)*f+lambda*f0
+      else
+         f0=f
+      endif
+
+! Test valable seulement en 1D mais pas genant
+      if (.not. (f0(1).ge.0.) ) then
+           stop'Dans thermcell_main'
+      endif
+
+!-------------------------------------------------------------------------------
+!deduction des flux
+!-------------------------------------------------------------------------------
+
+      CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,lev_out,lunout1,igout)
+!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux'
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax  ')
+
+!------------------------------------------------------------------
+!   On ne prend pas directement les profils issus des calculs precedents
+!   mais on s'autorise genereusement une relaxation vers ceci avec
+!   une constante de temps tau_thermals (typiquement 1800s).
+!------------------------------------------------------------------
+
+      if (tau_thermals>1.) then
+         lambda=exp(-ptimestep/tau_thermals)
+         fm0=(1.-lambda)*fm+lambda*fm0
+         entr0=(1.-lambda)*entr+lambda*entr0
+!        detr0=(1.-lambda)*detr+lambda*detr0
+      else
+         fm0=fm
+         entr0=entr
+         detr0=detr
+      endif
+
+!c------------------------------------------------------------------
+!   calcul du transport vertical
+!------------------------------------------------------------------
+
+      call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse,  &
+     &                    zthl,zdthladj,zta,lev_out)
+      call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse,  &
+     &                   po,pdoadj,zoa,lev_out)
+
+!------------------------------------------------------------------
+! Calcul de la fraction de l'ascendance
+!------------------------------------------------------------------
+      do ig=1,klon
+         fraca(ig,1)=0.
+         fraca(ig,nlay+1)=0.
+      enddo
+      do l=2,nlay
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+     
+!------------------------------------------------------------------
+!  calcul du transport vertical du moment horizontal
+!------------------------------------------------------------------
+
+!IM 090508  
+      if (1.eq.1) then
+!IM 070508 vers. _dq       
+!     if (1.eq.0) then
+
+
+! Calcul du transport de V tenant compte d'echange par gradient
+! de pression horizontal avec l'environnement
+
+         call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,fraca,zmax  &
+     &    ,zu,zv,pduadj,pdvadj,zua,zva,lev_out)
+!IM 050508    &    ,zu,zv,pduadj,pdvadj,zua,zva,igout,lev_out)
+      else
+
+! calcul purement conservatif pour le transport de V
+         call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,zu,pduadj,zua,lev_out)
+         call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,zv,pdvadj,zva,lev_out)
+      endif
+
+!     print*,'13 OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'14 OK convect8'
+!------------------------------------------------------------------
+!   Calculs de diagnostiques pour les sorties
+!------------------------------------------------------------------
+!calcul de fraca pour les sorties
+      
+      if (sorties) then
+      if (prt_level.ge.1) print*,'14a OK convect8'
+! calcul du niveau de condensation
+! initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0
+         zcon(ig)=0.
+      enddo 
+!nouveau calcul
+      do ig=1,ngrid
+      CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1))
+      pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI
+      enddo
+      do k=1,nlay
+         do ig=1,ngrid
+         if ((pcon(ig).le.pplay(ig,k))  &
+     &      .and.(pcon(ig).gt.pplay(ig,k+1))) then
+            zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100.
+         endif
+         enddo
+      enddo
+      if (prt_level.ge.1) print*,'14b OK convect8'
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+         enddo
+      enddo
+      if (prt_level.ge.1) print*,'14c OK convect8'
+!calcul des moments
+!initialisation
+      do l=1,nlay
+         do ig=1,ngrid
+            q2(ig,l)=0.
+            wth2(ig,l)=0.
+            wth3(ig,l)=0.
+            ratqscth(ig,l)=0.
+            ratqsdiff(ig,l)=0.
+         enddo
+      enddo      
+      if (prt_level.ge.1) print*,'14d OK convect8'
+      print*,'WARNING thermcell_main wth2=0. si zw2 > 1.e-10'
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+!
+      if (prt_level.ge.10) print*,'14e OK convect8 ig,l,zf,zf2',ig,l,zf,zf2
+!
+      if (prt_level.ge.10) print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            if(zw2(ig,l).gt.1.e-10) then
+             wth2(ig,l)=zf2*(zw2(ig,l))**2
+            else
+             wth2(ig,l)=0.
+            endif
+!           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))  &
+     &                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+      if (prt_level.ge.10) print*,'14g OK convect8 ig,l,po',ig,l,po(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+!test: on calcul q2/po=ratqsc
+            ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.))
+         enddo
+      enddo
+!calcul de ale_bl et alp_bl
+!pour le calcul d'une valeur intégrée entre la surface et lmax
+      do ig=1,ngrid
+      alp_int(ig)=0.
+      ale_int(ig)=0.
+      n_int(ig)=0
+      enddo
+!
+      do l=1,nlay
+      do ig=1,ngrid
+       if(l.LE.lmax(ig)) THEN
+        alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)
+        ale_int(ig)=ale_int(ig)+0.5*zw2(ig,l)**2
+        n_int(ig)=n_int(ig)+1
+       endif
+      enddo
+      enddo
+!      print*,'avant calcul ale et alp' 
+!calcul de ALE et ALP pour la convection
+      do ig=1,ngrid
+!      Alp_bl(ig)=0.5*rhobarz(ig,lmix_bis(ig))*wth3(ig,lmix(ig))
+!          Alp_bl(ig)=0.5*rhobarz(ig,nivcon(ig))*wth3(ig,nivcon(ig))
+!      Alp_bl(ig)=0.5*rhobarz(ig,lmix(ig))*wth3(ig,lmix(ig)) 
+!     &           *0.1
+!valeur integree de alp_bl * 0.5:
+       if (n_int(ig).gt.0) then
+       Alp_bl(ig)=0.5*alp_int(ig)/n_int(ig)
+!       if (Alp_bl(ig).lt.0.) then
+!       Alp_bl(ig)=0.
+       endif
+!       endif
+!         write(18,*),'rhobarz,wth3,Alp',rhobarz(ig,nivcon(ig)),
+!     s               wth3(ig,nivcon(ig)),Alp_bl(ig)
+!            write(18,*),'ALP_BL',Alp_bl(ig),lmix(ig)
+!      Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2
+!      if (nivcon(ig).eq.1) then
+!       Ale_bl(ig)=0.
+!       else
+!valeur max de ale_bl:
+       Ale_bl(ig)=0.5*zw2(ig,lmix(ig))**2 
+!     & /2.
+!     & *0.1
+!        Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2 
+!       if (n_int(ig).gt.0) then
+!       Ale_bl(ig)=ale_int(ig)/n_int(ig)
+!        Ale_bl(ig)=4.
+!       endif
+!       endif
+!            Ale_bl(ig)=0.5*wth2(ig,lmix_bis(ig))
+!          Ale_bl(ig)=wth2(ig,nivcon(ig))
+!          write(19,*),'wth2,ALE_BL',wth2(ig,nivcon(ig)),Ale_bl(ig)
+      enddo
+!test:calcul de la ponderation des couches pour KE
+!initialisations
+!      print*,'ponderation'
+      do ig=1,ngrid
+           fm_tot(ig)=0.
+      enddo
+       do ig=1,ngrid
+        do k=1,klev
+           wght_th(ig,k)=1.
+        enddo
+       enddo
+       do ig=1,ngrid
+!         lalim_conv(ig)=lmix_bis(ig)
+!la hauteur de la couche alim_conv = hauteur couche alim_therm
+         lalim_conv(ig)=lalim(ig)
+!         zentr(ig)=zlev(ig,lalim(ig))
+      enddo
+      do ig=1,ngrid
+        do k=1,lalim_conv(ig)
+           fm_tot(ig)=fm_tot(ig)+fm(ig,k)
+        enddo
+      enddo
+      do ig=1,ngrid
+        do k=1,lalim_conv(ig)
+           if (fm_tot(ig).gt.1.e-10) then
+!           wght_th(ig,k)=fm(ig,k)/fm_tot(ig)
+           endif
+!on pondere chaque couche par a*
+             if (alim_star(ig,k).gt.1.e-10) then
+             wght_th(ig,k)=alim_star(ig,k)
+             else
+             wght_th(ig,k)=1.
+             endif
+        enddo
+      enddo
+!      print*,'apres wght_th'
+!test pour prolonger la convection
+      do ig=1,ngrid
+!v1d  if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then
+      if ((alim_star(ig,1).lt.1.e-10)) then
+      lalim_conv(ig)=1
+      wght_th(ig,1)=1.
+!      print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1)
+      endif
+      enddo
+
+!calcul du ratqscdiff
+      if (prt_level.ge.1) print*,'14e OK convect8'
+      var=0.
+      vardiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lalim(ig)
+            var=var+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      if (prt_level.ge.1) print*,'14f OK convect8'
+      do ig=1,ngrid
+          do l=1,lalim(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+          vardiff=vardiff+alim_star(ig,l)  &
+     &           *(zqta(ig,l)*1000.-var)**2
+!         ratqsdiff=ratqsdiff+alim_star(ig,l)*
+!     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      if (prt_level.ge.1) print*,'14g OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+            ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.)   
+!           write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+         enddo
+      enddo 
+!--------------------------------------------------------------------    
+!
+!ecriture des fichiers sortie
+!     print*,'15 OK convect8'
+
+      isplit=isplit+1       
+
+
+#ifdef und
+      if (prt_level.ge.1) print*,'thermcell_main sorties 1D'
+#include "thermcell_out1d.h"
+#endif
+
+
+#define troisD
+#undef troisD
+      if (prt_level.ge.1) print*,'thermcell_main sorties 3D'
+#ifdef troisD
+#include "thermcell_out3d.h"
+#endif
+
+      endif
+
+      if (prt_level.ge.1) print*,'thermcell_main FIN  OK'
+
+!     if(icount.eq.501) stop'au pas 301 dans thermcell_main'
+      return
+      end
+
+!-----------------------------------------------------------------------------
+
+      subroutine test_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment)
+      IMPLICIT NONE
+#include "iniprint.h"
+
+      integer i, k, klon,klev
+      real pplev(klon,klev+1),pplay(klon,klev)
+      real ztv(klon,klev)
+      real po(klon,klev)
+      real ztva(klon,klev)
+      real zqla(klon,klev)
+      real f_star(klon,klev)
+      real zw2(klon,klev)
+      integer long(klon)
+      real seuil
+      character*21 comment
+
+      if (prt_level.ge.1) THEN
+       print*,'WARNING !!! TEST ',comment
+      endif
+      return
+
+!  test sur la hauteur des thermiques ...
+         do i=1,klon
+!IMtemp           if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then
+           if (prt_level.ge.10) then
+               print*,'WARNING ',comment,' au point ',i,' K= ',long(i)
+               print*,'  K  P(MB)  THV(K)     Qenv(g/kg)THVA        QLA(g/kg)   F*        W2'
+               do k=1,klev
+                  write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k)
+               enddo
+!              stop
+           endif
+         enddo
+
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_old.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_old.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_old.F	(revision 984)
@@ -0,0 +1,6105 @@
+      SUBROUTINE thermcell_2002(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmax(klon,klev+1),lmaxa(klon),lmix(klon)
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon,klev),wmaxa(klon)
+
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      character (len=2) :: str2
+      character (len=10) :: str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+            wa(ig,k,k)=0.
+            wa(ig,k,k+1)=2.*RG*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig,k+1)
+     s      *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+         do l=k+1,nlay-1
+            do ig=1,ngrid
+               wa(ig,k,l+1)=wa(ig,k,l)+
+     s         2.*RG*(ztv(ig,k)-ztv(ig,l))/ztv(ig,l)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+            enddo
+         enddo
+         do ig=1,ngrid
+            wa(ig,k,nlay+1)=0.
+         enddo
+      enddo
+
+c     print*,'4 OK convect8'
+c Calcul de la couche correspondant a la hauteur du thermique
+      do k=1,nlay-1
+         do ig=1,ngrid
+            lmax(ig,k)=k
+         enddo
+         do l=nlay,k+1,-1
+            do ig=1,ngrid
+               if(wa(ig,k,l).le.1.e-10) lmax(ig,k)=l-1
+            enddo
+         enddo
+      enddo
+
+c     print*,'5 OK convect8'
+c   Calcule du w max du thermique
+      do k=1,nlay
+      do ig=1,ngrid
+         wmax(ig,k)=0.
+      enddo
+      enddo
+
+      do k=1,nlay-1
+         do l=k,nlay
+            do ig=1,ngrid
+               if (l.le.lmax(ig,k)) then
+                  wa(ig,k,l)=sqrt(wa(ig,k,l))
+                  wmax(ig,k)=max(wmax(ig,k),wa(ig,k,l))
+               else
+                  wa(ig,k,l)=0.
+               endif
+            enddo
+         enddo
+      enddo
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+             pu_therm(ig,k)=sqrt(wmax(ig,k))
+             pv_therm(ig,k)=sqrt(wmax(ig,k))
+         enddo
+      enddo
+
+c     print*,'6 OK convect8'
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+      enddo
+c     print*,'LMAX LMAX LMAX '
+      do k=1,nlay-1
+         do  ig=1,ngrid
+            zmax(ig)=max(zmax(ig),zlev(ig,lmax(ig,k))-zlev(ig,k))
+         enddo
+c     print*,k,lmax(1,k)
+      enddo
+c     print*,'ZMAX ZMAX ZMAX ',zmax
+c      call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX      ')
+
+c   Calcul de l'entrainement.
+c   Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur
+c   de la couche d'alimentation en partant du principe que la vitesse
+c   maximum dans l'ascendance est la vitesse d'entrainement horizontale.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzz=rho(ig,k)*wmax(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+     s    /(zmax(ig)*r_aspect)
+            if(w2di.eq.2) then
+               entr(ig,k)=entr(ig,k)+
+     s         ptimestep*(zzz-entr(ig,k))/float(tho)
+            else
+               entr(ig,k)=zzz
+            endif
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+
+      do l=1,nlay-2
+         do ig=1,ngrid
+c           if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then
+c         print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1)
+            if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)
+     s       .and.entr(ig,l).gt.1.e-10) then
+c        print*,'COUCOU cas 1'
+c   Initialisation de l'ascendance
+c              lmix(ig)=1
+               ztva(ig,l)=ztv(ig,l)
+               fmc(ig,l)=0.
+               fmc(ig,l+1)=entr(ig,l)
+               zw2(ig,l)=0.
+c     if (.not.ztv(ig,l+1).gt.150.) then
+c     print*,'ig,l+1,ztv(ig,l+1)'
+c     print*, ig,l+1,ztv(ig,l+1)
+c        stop'dans thermiques'
+c     endif
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+               larg_detr(ig,l)=0.
+            else if (zw2(ig,l).ge.1.e-10.and.
+     .               fmc(ig,l)+entr(ig,l).gt.1.e-10) then
+c   Incrementation...
+               fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+c     if (.not.fmc(ig,l+1).gt.1.e-15) then
+c     print*,'ig,l+1,fmc(ig,l+1)'
+c     print*, ig,l+1,fmc(ig,l+1)
+c     print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1)
+c     print*,'W2 ',(zw2(ig,ll),ll=1,klev+1)
+c     print*,'Tv ',(ztv(ig,ll),ll=1,klev)
+c     print*,'Entr ',(entr(ig,ll),ll=1,klev)
+c        stop'dans thermiques'
+c     endif
+               ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))
+     s          /fmc(ig,l+1)
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+               zw2(ig,l+1)=zw2(ig,l)*(fmc(ig,l)/fmc(ig,l+1))**2+
+     s         2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+            if (zw2(ig,l+1).lt.0.) then
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+c        print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig)
+         enddo
+      enddo
+
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+               if(l.gt.lmix(ig)) then
+                  xxx(ig,l)=(lmaxa(ig)+1.-l) / (lmaxa(ig)+1.-lmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fraca(ig,lmix(ig))
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)**2
+           endif
+               endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo
+
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c     print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c     print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c     print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE thermcell_cld(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev,debut
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0,zqla,lmax
+     s                  ,zmax_sec,wmax_sec,zw_sec,lmix_sec
+     s                  ,ratqscth,ratqsdiff
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon)
+      real alpha
+      save alpha
+      data alpha/1./
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+      real zmax_sec(klon)
+      real zmax_sec2(klon)
+      real zw_sec(klon,klev+1)
+      INTEGER lmix_sec(klon)
+      real w_est(klon,klev+1)
+con garde le zmax du pas de temps precedent
+c      real zmax0(klon)
+c      save zmax0
+c      real zmix0(klon)
+c      save zmix0 
+      REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:)
+c$OMP THREADPRIVATE(zmax0, zmix0)
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+      real dtheta(klon,klev)
+!      common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real sum
+      real sumdiff
+      real ratqsdiff(klon,klev)
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wmax_sec(klon)
+      real wmax_sec2(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real massetot(klon,klev)
+      real detr0(klon,klev)
+      real alim0(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+cCR niveau de condensation
+      real nivcon(klon)
+      real zcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+      PARAMETER (DDT0=.01)
+
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real entr_star_tot(klon)
+      real detr_star_tot(klon)
+      real alim_star(klon,klev)
+      real alim(klon,klev)
+      real nu(klon,klev)
+      real nu_e(klon,klev)
+      real nu_min
+      real nu_max
+      real nu_r
+      real f(klon)
+c      real f(klon), f0(klon)
+c     save f0
+      REAL,SAVE, ALLOCATABLE :: f0(:)
+c$OMP THREADPRIVATE(f0)
+
+      real f_old
+      real zlevinter(klon)
+      logical, save :: first = .true.
+c      data first /.false./
+c      save first
+      logical nuage
+c      save nuage
+      logical boucle
+      logical therm
+      logical debut
+      logical rale
+      integer test(klon)
+      integer signe_zw2
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c
+
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+      if (first) then
+        allocate(zmix0(klon))
+        allocate(zmax0(klon))
+        allocate(f0(klon))
+        first=.false.
+      endif
+
+       sorties=.false.
+c     print*,'NOUVEAU DETR PLUIE '
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+cinitialisations de zqsat
+      DO ll=1,nlay
+         DO ig=1,ngrid
+            zqsat(ig,ll)=0.
+            zqsatth(ig,ll)=0.
+         ENDDO
+      ENDDO
+c
+con met le first a true pour le premier passage de la journée
+      do ig=1,klon
+            test(ig)=0
+      enddo
+      if (debut) then
+         do ig=1,klon
+            test(ig)=1
+            f0(ig)=0.
+            zmax0(ig)=0.
+         enddo
+      endif
+      do ig=1,klon      
+         if ((.not.debut).and.(f0(ig).lt.1.e-10)) then
+            test(ig)=1
+         endif
+      enddo 
+c     do ig=1,klon
+c        print*,'test(ig)',test(ig),zmax0(ig)
+c     enddo
+      nuage=.false.
+c-----------------------------------------------------------------------
+cAM Calcul de T,q,ql a partir de Tl et qT
+c   ---------------------------------------------------
+c
+c Pr Tprec=Tl calcul de qsat 
+c Si qsat>qT T=Tl, q=qT
+c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+c On cherche DDT < DDT0
+c
+c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+c
+c
+       DO ll=1,nlay
+c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 1.e-10)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig).and.(1.eq.1)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+c            write(18,*),'DT0=',DT
+c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (abs(DT).gt.DDT0)
+c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              if (denom.lt.1.e-10) then
+                  print*,'pb denom'
+              endif
+              DT=num/denom
+            enddo
+c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+con ecrit zqsat 
+            zqsat(ig,ll)=qsatbef(ig)     
+         EndDO
+       EndDO
+cAM fin
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c     print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+             zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
+c            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+c            zo(ig,l)=po(ig,l)
+c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+cAM attention zh est maintenant le profil de T et plus le profil de theta !
+c
+c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))
+     s           -zl(ig,l))
+cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+c            
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+ccalcul de deltaz
+      do l=1,nlay
+         do ig=1,ngrid
+            deltaz(ig,l)=zlev(ig,l+1)-zlev(ig,l)
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+cCr:ajout:calcul de la masse
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des alim_star tels que alim=f*alim_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+            alim(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+c
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.lt.lentr(ig)) then
+cdef possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)
+c     s                       *(zlev(ig,l+1)-zlev(ig,l))
+     s                       *sqrt(zlev(ig,l+1))
+c             alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.) 
+            endif
+         enddo
+      enddo
+      
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+c         if (lmin(ig).gt.1) then
+cCRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,klev
+                alim_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+         entr_star_tot(ig)=0.
+         detr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
+         enddo
+      enddo
+c
+c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (alim_star_tot(ig).gt.1.e-10) then
+c         do l=1,lentr(ig)
+          do l=1,klev
+cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+         enddo
+         endif
+      enddo
+       
+c     print*,'fin calcul alim_star'
+
+cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+cn     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+      nu_min=l_mix
+      nu_max=1000.
+c      do ig=1,ngrid
+c      nu_max=wmax_sec(ig)
+c      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            nu(ig,k)=0.
+            nu_e(ig,k)=0.
+         enddo
+      enddo
+cCalcul de l'excès de température du à la diffusion turbulente
+      do ig=1,ngrid
+         do l=1,klev
+            dtheta(ig,l)=0.
+         enddo
+       enddo
+      do ig=1,ngrid
+         do l=1,lentr(ig)-1
+      dtheta(ig,l)=sqrt(10.*0.4*zlev(ig,l+1)**2*1.
+     s          *((ztv(ig,l+1)-ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2)
+         enddo
+       enddo
+c      do l=1,nlay-2
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.alim_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+cAM
+ctest:on rajoute un excès de T dans couche alim
+c               ztla(ig,l)=zthl(ig,l)+dtheta(ig,l)
+               ztla(ig,l)=zthl(ig,l) 
+ctest: on rajoute un excès de q dans la couche alim
+c               zqta(ig,l)=po(ig,l)+0.001
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+cAM
+               f_star(ig,l+1)=alim_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+               larg_detr(ig,l)=0.
+c     print*,'coucou boucle 1'
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+c     print*,'coucou boucle 2'
+cestimation du detrainement a partir de la geometrie du pas precedent
+      if ((test(ig).eq.1).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
+                  detr_star(ig,l)=0.
+                  entr_star(ig,l)=0.
+c     print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig)
+             else
+c     print*,'coucou debut detr'
+ctests sur la definition du detr
+        if (zqla(ig,l-1).gt.1.e-10) then
+           nuage=.true.
+        endif 
+
+             w_est(ig,l+1)=zw2(ig,l)*
+     s                   ((f_star(ig,l))**2)
+     s                   /(f_star(ig,l)+alim_star(ig,l))**2+
+     s                   2.*RG*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l)
+     s                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+      if (l.gt.2) then
+             if ((w_est(ig,l+1).gt.w_est(ig,l)).and.
+     s           (zlev(ig,l+1).lt.zmax_sec(ig)).and.
+     s            (zqla(ig,l-1).lt.1.e-10)) then 
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)
+     s                *sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)*zlev(ig,l+1))
+     s       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)*zlev(ig,l)))
+     s       /(r_aspect*zmax_sec(ig)))
+             else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.
+     s                (zqla(ig,l-1).lt.1.e-10)) then
+       detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))
+     s /(rhobarz(ig,lmix(ig))*wmaxa(ig))*
+     s (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))
+     s *((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))
+     s **2.
+     s -rhobarz(ig,l)*sqrt(w_est(ig,l))
+     s *((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))
+     s **2.)
+             else
+       detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)
+     s                *(zlev(ig,l+1)-zlev(ig,l))
+             
+             endif
+        else
+        detr_star(ig,l)=0.
+        endif
+       
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if (nuage) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         else
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         endif
+
+             if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+c              entr_star(ig,l)=0.
+              endif
+
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+c                 detr_star(ig,l)=0.
+             endif  
+
+c           print*,'ok detr_star'
+      endif
+cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+     s                      -detr_star(ig,l)
+ctest
+c             if (f_star(ig,l+1).lt.0.) then
+c                f_star(ig,l+1)=0.
+c                entr_star(ig,l)=0.
+c                detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)
+c             endif
+ctest sur le signe de f_star
+       if (f_star(ig,l+1).gt.1.e-10) then 
+c                 then
+ctest
+c         if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then
+cAM on melange Tl et qt du thermique
+con rajoute un excès de T dans la couche alim
+c               if (l.lt.lentr(ig)) then
+c           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+c     s     (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l)))
+c     s     /(f_star(ig,l+1)+detr_star(ig,l))
+c               else
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+     s                    (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))
+     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c     s                    /(f_star(ig,l+1)) 
+c               endif
+con rajoute un excès de q dans la couche alim
+c               if (l.lt.lentr(ig)) then
+c               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+c     s           (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001))
+c     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c               else
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+     s                    (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))
+     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c     s                   /(f_star(ig,l+1))
+c               endif
+cAM on en deduit thetav et ql du thermique
+cCR test
+c               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)  
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+             Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 1.e-10)
+
+           if (Zsat(ig).and.(1.eq.1)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+c             write(17,*)'DT0=',DT
+              do while (abs(DT).gt.DDT0)
+c                 print*,'aie'
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 if (denom.lt.1.e-10) then
+                    print*,'pb denom'
+                 endif
+                 DT=num/denom
+c                 write(17,*)'DT=',DT
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+              zqla(ig,l) = max(0.,qlbef) 
+c              zqla(ig,l)=0.
+             endif
+c             zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+c      
+c on ecrit de maniere conservative (sat ou non)
+c          T = Tl +Lv/Cp ql
+cCR rq utilisation de humidite specifique ou rapport de melange?
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+con rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+c           if (l.lt.lentr(ig)) then
+c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+c     s              -zqla(ig,l))-zqla(ig,l)) + 0.1
+c           else
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+     s              -zqla(ig,l))-zqla(ig,l))
+c           endif
+c           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+c     s                 /(1.-retv*zqla(ig,l))
+c           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+c     s                 /(1.-retv*zqta(ig,l))
+c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+c       write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l))
+con ecrit zqsat 
+           zqsatth(ig,l)=qsatbef(ig)  
+c        enddo
+c        DO ig=1,ngrid
+c           if (zw2(ig,l).ge.1.e-10.and.
+c     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+c
+c            if (f_star(ig,l+1).gt.1.e-10) then
+            zw2(ig,l+1)=zw2(ig,l)*
+c     s                  ((f_star(ig,l)-detr_star(ig,l))**2)
+c     s                  /f_star(ig,l+1)**2+
+     s                   ((f_star(ig,l))**2)
+     s                   /(f_star(ig,l+1)+detr_star(ig,l))**2+
+c     s                    /(f_star(ig,l+1))**2+           
+     s                   2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                   *(zlev(ig,l+1)-zlev(ig,l))
+c     s                   *(f_star(ig,l)/f_star(ig,l+1))**2
+
+            endif
+        endif
+c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+c              print*,'linter=',linter(ig)
+c          else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then
+c               linter(ig)=l+1
+c               print*,'linter=l',zw2(ig,l),zw2(ig,l+1)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+c            wa_moy(ig,l+1)=zw2(ig,l+1) 
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+cpour le cas ou on prend tjs lmin=1
+c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+       write(11,*)'ig,lmax,linter',ig,lmax(ig),linter(ig)
+       write(12,*)'ig,zlevinter,zmax',ig,zmax(ig),zlevinter(ig)
+      enddo
+
+cCalcul de zmax_sec et wmax_sec
+      call fermeture_seche(ngrid,nlay
+     s                  ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk
+     s                  ,alim,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect
+     s                  ,zmax_sec2,wmax_sec2)
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+c en lmax f=d-e
+      do ig=1,ngrid
+c      entr_star(ig,lmax(ig))=0.
+c      f_star(ig,lmax(ig)+1)=0.
+c      detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig))
+c     s                       +alim_star(ig,lmax(ig))
+      enddo
+c
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+ccalcul de entr_star_tot
+      do ig=1,ngrid
+         do k=1,lmix(ig)
+            entr_star_tot(ig)=entr_star_tot(ig)
+c     s                        +entr_star(ig,k)
+     s                        +alim_star(ig,k)
+c     s                        -detr_star(ig,k)
+            detr_star_tot(ig)=detr_star_tot(ig)
+c     s                        +alim_star(ig,k)
+     s                        -detr_star(ig,k)
+     s                        +entr_star(ig,k)
+         enddo
+      enddo
+      
+      do ig=1,ngrid
+         if (alim_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else   
+c             do k=lmin(ig),lentr(ig)
+             do k=1,lentr(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then 
+             f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect
+     s             *alim_star2(ig))
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/
+     s                     zmax_sec(ig))*wmax_sec(ig))
+             else
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig))
+            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/
+     s                     zmax(ig))*wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+      enddo
+      print*,'apres fermeture'
+c Calcul de l'entrainement
+         do ig=1,ngrid 
+            do k=1,klev
+            alim(ig,k)=f(ig)*alim_star(ig,k)
+         enddo
+      enddo
+cCR:test pour entrainer moins que la masse
+c       do ig=1,ngrid
+c          do l=1,lentr(ig)
+c             if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+c                alim(ig,l+1)=alim(ig,l+1)+alim(ig,l)
+c     s                       -0.9*masse(ig,l)/ptimestep
+c                alim(ig,l)=0.9*masse(ig,l)/ptimestep
+c             endif
+c          enddo
+c       enddo
+c calcul du détrainement
+         do ig=1,klon
+             do k=1,klev
+            detr(ig,k)=f(ig)*detr_star(ig,k)
+            if (detr(ig,k).lt.0.) then
+c               print*,'detr1<0!!!'
+            endif
+            enddo
+            do k=1,klev
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+            if (entr(ig,k).lt.0.) then
+c               print*,'entr1<0!!!'
+            endif
+         enddo
+      enddo
+c
+c       do ig=1,ngrid
+c          do l=1,klev
+c          if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt.
+c     s          (masse(ig,l))) then  
+c      print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a='
+c     s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l)
+c      endif
+c      enddo
+c      enddo
+c Calcul des flux
+
+      do ig=1,ngrid
+         do l=1,lmax(ig)
+c         do l=1,klev
+c             fmc(ig,l+1)=f(ig)*f_star(ig,l+1)
+            fmc(ig,l+1)=fmc(ig,l)+alim(ig,l)+entr(ig,l)-detr(ig,l)
+c        print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+c     s  'f+1=',fmc(ig,l+1)
+          if (fmc(ig,l+1).lt.0.) then
+               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+               fmc(ig,l+1)=fmc(ig,l)
+               detr(ig,l)=alim(ig,l)+entr(ig,l)
+c               fmc(ig,l+1)=0.
+c               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+            endif
+c       if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+c          f_old=fmc(ig,l+1)
+c          fmc(ig,l+1)=fmc(ig,l)
+c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+c       endif
+       
+c        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+c          f_old=fmc(ig,l+1)
+c          fmc(ig,l+1)=fmc(ig,l)
+c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l)
+c       endif
+crajout du test sur alpha croissant
+cif test
+c       if (1.eq.0) then
+
+       if (l.eq.klev) then
+          print*,'THERMCELL PB ig=',ig,'   l=',l
+          stop
+       endif
+!       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+!     s     (l.ge.lentr(ig)).and.
+       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+     s         (l.ge.lentr(ig)) ) then
+          if ( ((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.
+     s     (fmc(ig,l)/(rhobarz(ig,l)*zw2(ig,l))))) then
+           f_old=fmc(ig,l+1)
+           fmc(ig,l+1)=fmc(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)
+     s                          /(rhobarz(ig,l)*zw2(ig,l))
+           detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) 
+c           detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.)
+c           entr(ig,l)=0.4*detr(ig,l)
+c           entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l)
+        endif
+        endif
+        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=fmc(ig,l)
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+       endif
+       if (detr(ig,l).gt.fmc(ig,l)) then
+               detr(ig,l)=fmc(ig,l)
+               entr(ig,l)=fmc(ig,l+1)-alim(ig,l)
+        endif
+       if (fmc(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fmc(ig,l+1)
+               fmc(ig,l+1)=0.
+               print*,'fmc2<0',l+1,lmax(ig)
+            endif
+            
+ctest pour ne pas avoir f=0 et d=e/=0
+c       if (fmc(ig,l+1).lt.1.e-10) then
+c          detr(ig,l+1)=0.
+c          entr(ig,l+1)=0.
+c          zqla(ig,l+1)=0.
+c          zw2(ig,l+1)=0.
+c          lmax(ig)=l+1
+c          zmax(ig)=zlev(ig,lmax(ig))
+c       endif 
+        if (zw2(ig,l+1).gt.1.e-10) then
+       if ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.
+     s      1.)) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=rhobarz(ig,l+1)*zw2(ig,l+1)
+          zw2(ig,l+1)=0.
+          zqla(ig,l+1)=0.
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+         lmax(ig)=l+1
+          zmax(ig)=zlev(ig,lmax(ig))
+          print*,'alpha>1',l+1,lmax(ig)
+       endif
+        endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cendif test
+c      endif
+      enddo
+      enddo
+      do ig=1,ngrid
+c         if (fmc(ig,lmax(ig)+1).ne.0.) then
+         fmc(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fmc(ig,lmax(ig))+entr(ig,lmax(ig))
+     s                     +alim(ig,lmax(ig))
+c         endif
+      enddo
+ctest sur le signe de fmc
+       do ig=1,ngrid
+         do l=1,klev+1
+            if (fmc(ig,l).lt.0.) then
+         print*,'fm1<0!!!','ig=',ig,'l=',l,'a=',alim(ig,l-1),'e='
+     s ,entr(ig,l-1),'f=',fmc(ig,l-1),'d=',detr(ig,l-1),'f+1=',fmc(ig,l)
+            endif
+         enddo
+       enddo
+ctest de verification
+      do ig=1,ngrid
+       do l=1,lmax(ig)
+       if ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+detr(ig,l)))
+     s           .gt.1.e-4) then
+c      print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+c     s  'f+1=',fmc(ig,l+1)
+       endif
+       if (detr(ig,l).lt.0.) then
+          print*,'detrdemi<0!!!'
+       endif
+         enddo
+      enddo
+c
+cRC
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+ctest
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+      do ig=1,klon
+         zmix0(ig)=zmix(ig)
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+cne devrait pas arriver!!!!!
+      do ig=1,ngrid
+       do l=1,klev
+          if (detr(ig,l).gt.(fmc(ig,l)+alim(ig,l))+entr(ig,l)) then
+             print*,'detr2>fmc2!!!','ig=',ig,'l=',l,'d=',detr(ig,l),
+     s             'f=',fmc(ig,l),'lmax=',lmax(ig)
+c             detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l)
+c             entr(ig,l)=0.
+c             fmc(ig,l+1)=0.
+c             zw2(ig,l+1)=0.     
+c             zqla(ig,l+1)=0.
+           print*,'pb!fm=0 et f_star>0',l,lmax(ig)        
+c             lmax(ig)=l
+          endif
+       enddo
+      enddo
+      do ig=1,ngrid
+         do l=lmax(ig)+1,klev+1
+c            fmc(ig,l)=0.
+c            detr(ig,l)=0.
+c            entr(ig,l)=0.
+c            zw2(ig,l)=0.
+c            zqla(ig,l)=0.
+         enddo
+      enddo
+
+cCalcul du detrainement lors du premier passage
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+         endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   cal1cul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          if (test(ig).eq.1) then
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+          endif
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                    xxx(ig,l)=(lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+      print*,'fin calcul fraca'
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              if (test(ig).eq.1) then
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (alim(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+              endif
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay+1
+         do ig=1,ngrid
+            if (test(ig).eq.0) then
+              fm(ig,l)=fmc(ig,l)
+            endif
+         enddo
+      enddo 
+   
+cfin du first
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+      print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+     s         ,fm(ig,l+1)*ptimestep
+     s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if((alim(ig,l)+entr(ig,l))*ptimestep.gt.masse(ig,l)) then
+      print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+     s         ,(entr(ig,l)+alim(ig,l))*ptimestep
+     s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.alim(ig,l).ge.0..or..not.alim(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+cCR:test:on ne change pas la def du entr mais la def du fm
+       do l=1,nlay
+         do ig=1,ngrid
+            if (test(ig).eq.1) then
+            detr(ig,l)=fm(ig,l)+alim(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+alim(ig,l)
+                detr(ig,l)=0.
+c                write(11,*)'l,ig,entr',l,ig,entr(ig,l)
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+            endif
+         enddo
+      enddo
+cRC
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(alim+entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=alim+entr
+         detr0=detr
+         alim0=alim
+c         zoa=zqta
+c         entr0=alim
+      endif
+
+      if (1.eq.1) then
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zh,zdhadj,zha)
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,
+     .                    zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,
+     .                   po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+cCalcul des moments
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+c            zf2=zf/(1.-zf)
+c            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+c            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+c         enddo
+c      enddo
+
+
+
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+ccalcul de fraca pour les sorties
+      do l=2,klev
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+c CR calcul du niveau de condensation
+c initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0.
+         zcon(ig)=0.
+      enddo 
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+c            if (zcon(ig).gt.1.e-10) then
+c               nuage=.true.
+c            else 
+c               nuage=.false.
+c            endif
+         enddo
+      enddo
+      
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            wth2(ig,l)=zf2*(zw2(ig,l))**2
+c           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))
+     s                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+ctest: on calcul q2/po=ratqsc
+c            if (nuage) then
+            ratqscth(ig,l)=sqrt(q2(ig,l))/(po(ig,l)*1000.)
+c            else
+c            ratqscth(ig,l)=0.
+c            endif
+         enddo
+      enddo
+ccalcul du ratqscdiff
+      sum=0.
+      sumdiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lentr(ig)
+            sum=sum+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      do ig=1,ngrid
+          do l=1,lentr(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+       sumdiff=sumdiff+alim_star(ig,l)
+     s           *(zqta(ig,l)*1000.-sum)**2
+c      ratqsdiff=ratqsdiff+alim_star(ig,l)*
+c     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      do l=1,klev
+      do ig=1,ngrid
+      ratqsdiff(ig,l)=sqrt(sumdiff)/(po(ig,l)*1000.)   
+c      write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+      enddo
+      enddo     
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1       
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+c         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+c         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+c         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+c         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+c         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+c         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,w_est,'w_est      ','w_est      ')
+con sort les moments
+         call wrgradsfi(1,nlay,thetath2,'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2,'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3,'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2,'q2       ','q2       ')
+         call wrgradsfi(1,nlay,dtheta,'dT       ','dT       ')
+c
+         call wrgradsfi(1,nlay,zw_sec,'zw_sec       ','zw_sec       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+         call wrgradsfi(1,nlay,nu,'nu       ','nu       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa,'zoa        ','zoa        ')
+c         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+c         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',
+     s        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz,'deltaz      ','deltaz      ')
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  ,'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    ,'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    ,'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    ,'alim_star   ','alim_star   ')
+      call wrgradsfi(1,nlay,alim    ,'alim   ','alim   ')
+      call wrgradsfi(1,1,f,'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot,'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,alim_star2,'a_2      ','a_2      ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec,'z_sec      ','z_sec      ')
+c      call wrgradsfi(1,1,zmax_sec2,'zz_se      ','zz_se      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      call wrgradsfi(1,1,nivcon,'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon,'zcon      ','zcon      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec,'w_sec      ','w_sec      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+           str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+      SUBROUTINE thermcell_eau(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+ 
+      PARAMETER (DDT0=.01)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c
+
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+c
+c-----------------------------------------------------------------------
+cAM Calcul de T,q,ql a partir de Tl et qT
+c   ---------------------------------------------------
+c
+c Pr Tprec=Tl calcul de qsat 
+c Si qsat>qT T=Tl, q=qT
+c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+c On cherche DDT < DDT0
+c
+c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+c
+c
+       DO ll=1,nlay
+c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 0.00001)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (DT.gt.DDT0)
+c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+c          dqsat_dT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              DT=num/denom
+            enddo
+c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+         EndDO
+       EndDO
+cAM fin
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+c            zo(ig,l)=po(ig,l)
+c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+cAM attention zh est maintenant le profil de T et plus le profil de theta !
+c
+c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))
+     s           -zl(ig,l))
+cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+c            
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-1,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).lt.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                          (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo
+c
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+cAM
+               ztla(ig,l)=zthl(ig,l)
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+cAM
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+c
+cAM on melange Tl et qt du thermique
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)
+     s                    *zthl(ig,l))/f_star(ig,l+1)
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)
+     s                    *po(ig,l))/f_star(ig,l+1)
+c
+c               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+c     s                    *ztv(ig,l))/f_star(ig,l+1)
+c
+cAM on en deduit thetav et ql du thermique
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+               Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 0.00001)
+            endif
+         enddo
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+              do while (DT.gt.DDT0)
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+           endif
+c on ecrit de maniere conservative (sat ou non)
+c          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+     s              -zqla(ig,l))-zqla(ig,l))
+
+        enddo
+        DO ig=1,ngrid
+           if (zw2(ig,l).ge.1.e-10.and.
+     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+c
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))
+     s             *entr_star_tot(ig)
+ctest
+             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+     s             *wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+         first=.true.
+      enddo
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+         else 
+         zmix(ig)=0.
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c     print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zh,zdhadj,zha)
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c     print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',
+     s        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c     print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE thermcell(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                           (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+
+      subroutine dqthermcell(ngrid,nlay,ptimestep,fm,entr,
+     .           masse,q,dq,qa)
+      USE dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+ctest
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+c               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+c     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+c               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+c               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+c               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+c               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+c               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+c            if (dq(ig,k).lt.0.) then
+c               print*,'dq<0!!!'
+c            endif
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      USE dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev)
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itère sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+c              gamma0=0.
+c   la première fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*u(ig,k)
+            wvd(ig,k)=fm(ig,k)*v(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*u(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*v(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac
+     .    ,q,dq,qa)
+      USE dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay),frac(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+      real qe(klon,klev),zf,zf2
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+         qe(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+               zf=0.5*(frac(ig,k)+frac(ig,k+1))
+               zf2=1./(1.-zf)
+               qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2)
+               qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2
+            else
+               qa(ig,k)=q(ig,k)
+               qe(ig,k)=q(ig,k)
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*qe(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      use dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),zf,zf2
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real ue(klon,klev),ve(klon,klev)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itère sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+     s         *1.
+c    s         *0.5
+c              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+c   la première fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+c   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+c   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      SUBROUTINE thermcell_sec(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      use dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+c     s                           (zlev(ig,l+1)-zlev(ig,l))
+     s                           *sqrt(zlev(ig,l+1))
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+c      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+c      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+cCR:test pour entrainer moins que la masse
+       do ig=1,ngrid
+          do l=1,lentr(ig)
+             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+     s                       -0.9*masse(ig,l)/ptimestep
+                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+             endif
+          enddo
+       enddo
+cCR: fin test
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+c                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+cRC
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+c      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c      print*,'19 OK convect8'
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_out1d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_out1d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_out1d.h	(revision 984)
@@ -0,0 +1,23 @@
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!   recalcul des flux en diagnostique...
+!     print*,'PAS DE TEMPS ',ptimestep
+!       call dt2F(pplev,pplay,pt,pdtadj,wh)
+!      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_out3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_out3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_out3d.h	(revision 984)
@@ -0,0 +1,72 @@
+!       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,w_est,'w_est      ','w_est      ')
+!on sort les moments
+         call wrgradsfi(1,nlay,thetath2,'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2,'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3,'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2,'q2       ','q2       ')
+!
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa,'zoa        ','zoa        ')
+
+!nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',  &
+     &        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz,'deltaz      ','deltaz      ')
+!nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  ,'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    ,'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    ,'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    ,'alim_star   ','alim_star   ')
+      call wrgradsfi(1,nlay,alim    ,'alim   ','alim   ')
+      call wrgradsfi(1,1,f,'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot,'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,alim_star2,'a_2      ','a_2      ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec,'z_sec      ','z_sec      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      call wrgradsfi(1,1,nivcon,'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon,'zcon      ','zcon      ')
+      call wrgradsfi(1,1,zcon2,'zcon2      ','zcon2      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec,'w_sec      ','w_sec      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+      print*,'Fin des wrgradsfi'
Index: LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_plume.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_plume.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/thermcell_plume.F90	(revision 984)
@@ -0,0 +1,650 @@
+      SUBROUTINE thermcell_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,  &
+     &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,zqsatth,lmix,linter,lev_out)
+
+!--------------------------------------------------------------------------
+!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
+!--------------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+
+      INTEGER itap
+
+      INTEGER ngrid,klev
+      REAL ptimestep
+      REAL ztv(ngrid,klev)
+      REAL zthl(ngrid,klev)
+      REAL po(ngrid,klev)
+      REAL zl(ngrid,klev)
+      REAL rhobarz(ngrid,klev)
+      REAL zlev(ngrid,klev+1)
+      REAL pplev(ngrid,klev+1)
+      REAL pphi(ngrid,klev)
+      REAL zpspsk(ngrid,klev)
+      REAL alim_star(ngrid,klev)
+      REAL zmax_sec(ngrid)
+      REAL f0(ngrid)
+      REAL l_mix
+      REAL r_aspect
+      INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+      real zcon2(ngrid)
+
+      REAL ztva(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zqla(ngrid,klev)
+      REAL zqla0(ngrid,klev)
+      REAL zqta(ngrid,klev)
+      REAL zha(ngrid,klev)
+
+      REAL detr_star(ngrid,klev)
+      REAL coefc
+      REAL detr_stara(ngrid,klev)
+      REAL detr_starb(ngrid,klev)
+      REAL detr_starc(ngrid,klev)
+      REAL detr_star0(ngrid,klev)
+      REAL detr_star1(ngrid,klev)
+      REAL detr_star2(ngrid,klev)
+
+      REAL entr_star(ngrid,klev)
+      REAL entr_star1(ngrid,klev)
+      REAL entr_star2(ngrid,klev)
+      REAL detr(ngrid,klev)
+      REAL entr(ngrid,klev)
+
+      REAL zw2(ngrid,klev+1)
+      REAL w_est(ngrid,klev+1)
+      REAL f_star(ngrid,klev+1)
+      REAL wa_moy(ngrid,klev+1)
+
+      REAL ztva_est(ngrid,klev)
+      REAL zqla_est(ngrid,klev)
+      REAL zqsatth(ngrid,klev)
+
+      REAL linter(ngrid)
+      INTEGER lmix(ngrid)
+      INTEGER lmix_bis(ngrid)
+      REAL    wmaxa(ngrid)
+
+      INTEGER ig,l,k
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef,qsatbef
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      logical Zsat
+
+      Zsat=.false.
+! Initialisation
+      RLvCp = RLVTT/RCPD
+     
+      do l=1,klev
+         do ig=1,ngrid
+            zqla_est(ig,l)=0.
+            ztva_est(ig,l)=ztva(ig,l)
+            zqsatth(ig,l)=0.
+         enddo
+      enddo
+
+!AM:initialisations du thermique
+      do k=1,klev
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+!
+            ztva(ig,k) = ztla(ig,k)*zpspsk(ig,k)+RLvCp*zqla(ig,k)
+            ztva(ig,k) = ztva(ig,k)/zpspsk(ig,k)
+            zha(ig,k) = ztva(ig,k)
+!
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+
+           detr_stara(ig,k)=0.
+           detr_starb(ig,k)=0.
+           detr_starc(ig,k)=0.
+           detr_star0(ig,k)=0.
+           zqla0(ig,k)=0.
+           detr_star1(ig,k)=0.
+           detr_star2(ig,k)=0.
+           entr_star1(ig,k)=0.
+           entr_star2(ig,k)=0.
+
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+      if (prt_level.ge.1) print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            w_est(ig,k)=0.
+            f_star(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+!-----------------------------------------------------------------------------------
+!boucle de calcul de la vitesse verticale dans le thermique
+!-----------------------------------------------------------------------------------
+      do l=1,klev-1
+         do ig=1,ngrid
+
+
+
+! Calcul dans la premiere couche active du thermique (ce qu'on teste
+! en disant que la couche est instable et que w2 en bas de la couche
+! est nulle.
+
+            if (ztv(ig,l).gt.ztv(ig,l+1)  &
+     &         .and.alim_star(ig,l).gt.1.e-10  &
+     &         .and.zw2(ig,l).lt.1e-10) then
+
+
+! Le panache va prendre au debut les caracteristiques de l'air contenu
+! dans cette couche.
+               ztla(ig,l)=zthl(ig,l) 
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+               f_star(ig,l+1)=alim_star(ig,l)
+
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+!
+
+
+            else if ((zw2(ig,l).ge.1e-10).and.  &
+     &         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+!estimation du detrainement a partir de la geometrie du pas precedent
+!tests sur la definition du detr
+!calcul de detr_star et entr_star
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH le test miraculeux de Catherine ? Le bout du tunel ?
+!               w_est(ig,3)=zw2(ig,2)*  &
+!    &                   ((f_star(ig,2))**2)  &
+!    &                   /(f_star(ig,2)+alim_star(ig,2))**2+  &
+!    &                   2.*RG*(ztva(ig,1)-ztv(ig,2))/ztv(ig,2)  &
+!    &                   *(zlev(ig,3)-zlev(ig,2))
+!     if (l.gt.2) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+! Premier calcul de la vitesse verticale a partir de la temperature
+! potentielle virtuelle
+
+! FH CESTQUOI CA ????
+#define int1d2
+!#undef int1d2
+#ifdef int1d2
+      if (l.ge.2) then
+#else
+      if (l.gt.2) then
+#endif
+
+      if (1.eq.1) then
+          w_est(ig,3)=zw2(ig,2)* &
+     &      ((f_star(ig,2))**2) &
+     &      /(f_star(ig,2)+alim_star(ig,2))**2+ &
+     &      2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) &
+     &      *(zlev(ig,3)-zlev(ig,2))
+       endif
+
+
+!---------------------------------------------------------------------------
+!calcul de l entrainement et du detrainement lateral
+!---------------------------------------------------------------------------
+!
+!test:estimation de ztva_new_est sans entrainement
+
+               Tbef=ztla(ig,l-1)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               Zsat = (max(0.,zqta(ig,l-1)-qsatbef) .gt. 1.e-10)
+               if (Zsat) then
+               qlbef=max(0.,zqta(ig,l-1)-qsatbef)
+               DT = 0.5*RLvCp*qlbef
+               do while (abs(DT).gt.DDT0)
+                 Tbef=Tbef+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig,l-1)-qsatbef
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef+ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+               enddo
+                 zqla_est(ig,l) = max(0.,zqta(ig,l-1)-qsatbef) 
+               endif
+        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
+     &      -zqla_est(ig,l))-zqla_est(ig,l))
+
+             w_est(ig,l+1)=zw2(ig,l)*  &
+     &                   ((f_star(ig,l))**2)  &
+     &                   /(f_star(ig,l)+alim_star(ig,l))**2+  &
+     &                   2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+!
+!calcul du detrainement
+!=======================
+
+
+! Modifications du calcul du detrainement.
+! Dans la version de la these de Catherine, on passe brusquement
+! de la version seche a la version nuageuse pour le detrainement
+! ce qui peut occasioner des oscillations.
+! dans la nouvelle version, on commence par calculer un detrainement sec.
+! Puis un autre en cas de nuages.
+! Puis on combine les deux lineairement en fonction de la quantite d'eau.
+
+#define int1d3
+!#undef int1d3
+#define RIO_TH
+#ifdef RIO_TH
+!1. Cas non nuageux
+! 1.1 on est sous le zmax_sec et w croit
+          if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
+     &       (zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
+#ifdef int1d3
+     &       (zqla_est(ig,l).lt.1.e-10)) then 
+#else
+     &       (zqla(ig,l-1).lt.1.e-10)) then 
+#endif
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
+     &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
+     &       /(r_aspect*zmax_sec(ig)))
+             detr_stara(ig,l)=detr_star(ig,l)
+
+       if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l',ig,l
+
+! 1.2 on est sous le zmax_sec et w decroit
+          else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
+#ifdef int1d3
+     &            (zqla_est(ig,l).lt.1.e-10)) then
+#else
+     &            (zqla(ig,l-1).lt.1.e-10)) then
+#endif
+             detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
+     &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
+     &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
+     &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
+     &       *((zmax_sec(ig)-zlev(ig,l))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
+             detr_starb(ig,l)=detr_star(ig,l)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l',ig,l
+
+          else
+
+! 1.3 dans les autres cas
+             detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
+     &                      *(zlev(ig,l+1)-zlev(ig,l))
+             detr_starc(ig,l)=detr_star(ig,l)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 3 n: ig, l',ig, l
+             
+          endif
+
+#else
+
+! 1.1 on est sous le zmax_sec et w croit
+          if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
+     &       (zlev(ig,l+1).lt.zmax_sec(ig)) ) then
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
+     &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
+     &       /(r_aspect*zmax_sec(ig)))
+
+       if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l
+
+! 1.2 on est sous le zmax_sec et w decroit
+          else if ((zlev(ig,l+1).lt.zmax_sec(ig)) ) then
+             detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
+     &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
+     &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
+     &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
+     &       *((zmax_sec(ig)-zlev(ig,l))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
+       if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l
+
+          else
+             detr_star=0.
+          endif
+
+! 1.3 dans les autres cas
+          detr_starc(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
+     &                      *(zlev(ig,l+1)-zlev(ig,l))
+
+          coefc=min(zqla(ig,l-1)/1.e-3,1.)
+          if (zlev(ig,l+1).ge.zmax_sec(ig)) coefc=1.
+          coefc=1.
+! il semble qu'il soit important de baser le calcul sur
+! zqla_est(ig,l-1) plutot que sur zqla_est(ig,l)
+          detr_star(ig,l)=detr_starc(ig,l)*coefc+detr_star(ig,l)*(1.-coefc)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l', ig, l
+
+#endif
+
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 444: ig, l', ig, l
+!IM 730508 beg
+!        if(itap.GE.7200) THEN
+!         print*,'th_plume ig,l,itap,zqla_est=',ig,l,itap,zqla_est(ig,l)
+!        endif
+!IM 730508 end
+         
+         zqla0(ig,l)=zqla_est(ig,l)
+         detr_star0(ig,l)=detr_star(ig,l)
+!IM 060508 beg
+!         if(detr_star(ig,l).GT.1.) THEN
+!          print*,'th_plumeBEF ig l detr_star detr_starc coefc',ig,l,detr_star(ig,l) &
+!   &      ,detr_starc(ig,l),coefc
+!         endif
+!IM 060508 end
+!IM 160508 beg
+!IM 160508       IF (f0(ig).NE.0.) THEN
+           detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+!IM 160508       ELSE IF(detr_star(ig,l).EQ.0.) THEN
+!IM 160508        print*,'WARNING1  : th_plume f0=0, detr_star=0: ig, l, itap',ig,l,itap
+!IM 160508       ELSE
+!IM 160508        print*,'WARNING2  : th_plume f0=0, ig, l, itap, detr_star',ig,l,itap,detr_star(ig,l)
+!IM 160508       ENDIF
+!IM 160508 end
+!IM 060508 beg
+!        if(detr_star(ig,l).GT.1.) THEN
+!         print*,'th_plumeAFT ig l detr_star f0 1/f0',ig,l,detr_star(ig,l),f0(ig), &
+!   &     float(1)/f0(ig)
+!        endif
+!IM 060508 end
+        if (prt_level.ge.20) print*,'coucou calcul detr 445: ig, l', ig, l
+!
+!calcul de entr_star
+
+! #undef test2
+! #ifdef test2
+! La version test2 destabilise beaucoup le modele.
+! Il semble donc que ca aide d'avoir un entrainement important sous
+! le nuage.
+!         if (zqla_est(ig,l-1).ge.1.e-10.and.l.gt.lalim(ig)) then
+!          entr_star(ig,l)=0.4*detr_star(ig,l)
+!         else
+!          entr_star(ig,l)=0.
+!         endif
+! #else
+!
+! Deplacement du calcul de entr_star pour eviter d'avoir aussi
+! entr_star > fstar.
+! Redeplacer suite a la transformation du cas detr>f
+! FH
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 446: ig, l', ig, l
+#define int1d
+!FH 070508 #define int1d4
+!#undef int1d4
+! L'option int1d4 correspond au choix dans le cas ou le detrainement
+! devient trop grand.
+
+#ifdef int1d
+
+#ifdef int1d4
+#else
+       detr_star(ig,l)=min(detr_star(ig,l),f_star(ig,l))
+!FH 070508 plus
+       detr_star(ig,l)=min(detr_star(ig,l),1.)
+#endif
+
+       entr_star(ig,l)=max(0.4*detr_star(ig,l)-alim_star(ig,l),0.)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 447: ig, l', ig, l
+#ifdef int1d4
+! Si le detrainement excede le flux en bas + l'entrainement, le thermique
+! doit disparaitre.
+       if (detr_star(ig,l)>f_star(ig,l)+entr_star(ig,l)) then
+          detr_star(ig,l)=f_star(ig,l)+entr_star(ig,l)
+          f_star(ig,l+1)=0.
+          linter(ig)=l+1
+          zw2(ig,l+1)=-1.e-10
+       endif
+#endif
+
+
+#else
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 448: ig, l', ig, l
+        if(l.gt.lalim(ig)) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+        else
+
+! FH :
+! Cette ligne doit permettre de garantir qu'on a toujours un flux = 1
+! en haut de la couche d'alimentation.
+! A remettre en questoin a la premiere occasion mais ca peut aider a 
+! ecrire un code robuste.
+! Que ce soit avec ca ou avec l'ancienne facon de faire (e* = 0 mais
+! d* non nul) on a une discontinuité de e* ou d* en haut de la couche
+! d'alimentation, ce qui n'est pas forcement heureux.
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 449: ig, l', ig, l
+#undef pre_int1c
+#ifdef pre_int1c
+         entr_star(ig,l)=max(detr_star(ig,l)-alim_star(ig,l),0.)
+         detr_star(ig,l)=entr_star(ig,l)
+#else
+         entr_star(ig,l)=0.
+#endif
+
+        endif
+
+#endif
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 440: ig, l', ig, l
+        entr_star1(ig,l)=entr_star(ig,l)
+        detr_star1(ig,l)=detr_star(ig,l)
+!
+
+#ifdef int1d
+#else
+        if (detr_star(ig,l).gt.f_star(ig,l)) then
+
+!  Ce test est là entre autres parce qu'on passe par des valeurs
+!  delirantes de detr_star.
+!  ca vaut sans doute le coup de verifier pourquoi.
+
+           detr_star(ig,l)=f_star(ig,l)
+#ifdef pre_int1c
+           if (l.gt.lalim(ig)+1) then
+               entr_star(ig,l)=0.
+               alim_star(ig,l)=0.
+! FH ajout pour forcer a stoper le thermique juste sous le sommet
+! de la couche (voir calcul de finter)
+               zw2(ig,l+1)=-1.e-10
+               linter(ig)=l+1
+            else
+               entr_star(ig,l)=0.4*detr_star(ig,l)
+            endif
+#else
+           entr_star(ig,l)=0.4*detr_star(ig,l)
+#endif
+        endif
+#endif
+
+      else !l > 2
+         detr_star(ig,l)=0.
+         entr_star(ig,l)=0.
+      endif
+
+        entr_star2(ig,l)=entr_star(ig,l)
+        detr_star2(ig,l)=detr_star(ig,l)
+        if (prt_level.ge.20) print*,'coucou calcul detr 450: ig, l', ig, l
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH inutile si on conserve comme on l'a fait plus haut entr=detr
+! dans la couche d'alimentation
+!pas d entrainement dans la couche alim
+!      if ((l.le.lalim(ig))) then
+!           entr_star(ig,l)=0.
+!      endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!prise en compte du detrainement et de l entrainement dans le calcul du flux
+      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
+     &              -detr_star(ig,l)
+
+!test sur le signe de f_star
+        if (prt_level.ge.20) print*,'coucou calcul detr 451: ig, l', ig, l
+       if (f_star(ig,l+1).gt.1.e-10) then 
+!----------------------------------------------------------------------------
+!calcul de la vitesse verticale en melangeant Tl et qt du thermique
+!---------------------------------------------------------------------------
+!
+       Zsat=.false.
+       ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+!
+       zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+!  
+               Tbef=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)               
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               Zsat = (max(0.,zqta(ig,l)-qsatbef) .gt. 1.e-10)
+               if (Zsat) then
+               qlbef=max(0.,zqta(ig,l)-qsatbef)
+               DT = 0.5*RLvCp*qlbef
+               do while (abs(DT).gt.DDT0)
+                 Tbef=Tbef+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig,l)-qsatbef
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+                 zqla(ig,l) = max(0.,qlbef) 
+              endif
+!    
+        if (prt_level.ge.20) print*,'coucou calcul detr 4512: ig, l', ig, l
+! on ecrit de maniere conservative (sat ou non)
+!          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!on rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)  &
+     &              -zqla(ig,l))-zqla(ig,l))
+
+!on ecrit zqsat 
+           zqsatth(ig,l)=qsatbef  
+!calcul de vitesse
+           zw2(ig,l+1)=zw2(ig,l)*  &
+     &                 ((f_star(ig,l))**2)  &
+     &                 /(f_star(ig,l+1)+detr_star(ig,l))**2+             &
+     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                 *(zlev(ig,l+1)-zlev(ig,l))
+               
+            endif
+        endif
+        if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l
+!
+!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max 
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+                print*,'On tombe sur le cas particulier de thermcell_plume'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+            endif
+
+
+        if (zw2(ig,l+1).lt.0.) then 
+           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+           zw2(ig,l+1)=0.
+        endif
+
+           wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) 
+
+        if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+            lmix(ig)=l+1
+            wmaxa(ig)=wa_moy(ig,l+1)
+        endif
+        enddo
+      enddo
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
+#ifdef troisD
+      call wrgradsfi(1,klev,zqla_est,'ql_es     ','ql_es     ')
+      call wrgradsfi(1,klev,entr_star1,'e_st1     ','e_st1     ')
+      call wrgradsfi(1,klev,entr_star2,'e_st2     ','e_st2     ')
+      call wrgradsfi(1,klev,detr_stara,'d_sta     ','d_sta     ')
+      call wrgradsfi(1,klev,detr_starb,'d_stb     ','d_stb     ')
+      call wrgradsfi(1,klev,detr_starc,'d_stc     ','d_stc     ')
+      call wrgradsfi(1,klev,zqla0     ,'zqla0     ','zqla0     ')
+      call wrgradsfi(1,klev,detr_star0,'d_st0     ','d_st0     ')
+      call wrgradsfi(1,klev,detr_star1,'d_st1     ','d_st1     ')
+      call wrgradsfi(1,klev,detr_star2,'d_st2     ','d_st2     ')
+#endif
+
+!     print*,'thermcell_plume OK'
+
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/tilft43.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/tilft43.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/tilft43.F	(revision 984)
@@ -0,0 +1,95 @@
+!
+! $Header$
+!
+        SUBROUTINE TLIFT43(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
+        REAL GZ(ND),TPK(ND),CLW(ND),P(ND)
+        REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c -- sb:
+c!      CPD=1005.7
+c!      CPV=1870.0
+c!      CL=4190.0
+c!      RV=461.5
+c!      RD=287.04
+c!      LV0=2.501E6
+c!      G=9.8
+c!      ROWL=1000.0
+c ajouts:
+#include "YOMCST.h"
+        CPD = RCPD
+        CPV = RCPV
+        CL = RCW
+        LV0 = RLVTT
+        G = RG
+        ROWL= RATM/100.
+        GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+C sb --
+C
+        CPVMCL=CL-CPV
+        EPS=RD/RV
+        EPSI=1./EPS
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*(LV0-CPVMCL*(
+     1   T(NK)-273.15))+GZ(NK)
+        CPP=CPD*(1.-Q(NK))+Q(NK)*CPV
+        CPINV=1./CPP
+C
+        IF(KK.EQ.1)THEN
+C
+C   ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
+C
+        DO 50 I=1,ICB-1
+         CLW(I)=0.0
+   50   CONTINUE
+        DO 100 I=NK,ICB-1
+         TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV
+         TVP(I)=TPK(I)*(1.+Q(NK)*EPSI)
+  100   CONTINUE
+        END IF
+C
+C    ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
+C
+        NST=ICB
+        NSB=ICB
+        IF(KK.EQ.2)THEN  
+         NST=NL
+         NSB=ICB+1
+        END IF
+        DO 300 I=NSB,NST
+         TG=T(I)
+         QG=QS(I)
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         DO 200 J=1,2
+          S=CPD+ALV*ALV*QG/(RV*T(I)*T(I))
+          S=1./S
+          AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I)
+          TG=TG+S*(AH0-AHG)
+          TG=MAX(TG,35.0)
+          TC=TG-273.15
+          DENOM=243.5+TC
+          IF(TC.GE.0.0)THEN  
+           ES=6.112*EXP(17.67*TC/DENOM)
+          ELSE  
+           ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+          END IF  
+          QG=EPS*ES/(P(I)-ES*(1.-EPS))
+  200    CONTINUE
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD
+         CLW(I)=Q(NK)-QG
+         CLW(I)=MAX(0.0,CLW(I))
+         RG=QG/(1.-Q(NK))
+         TVP(I)=TPK(I)*(1.+RG*EPSI)
+  300   CONTINUE
+
+c -- sb:
+        RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+c sb --
+
+        RETURN
+        END
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/tlift.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/tlift.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/tlift.F	(revision 984)
@@ -0,0 +1,245 @@
+!
+! $Header$
+!
+        SUBROUTINE TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,
+     .                  TVP,TPK,CLW,ND,NL,
+     .                  DTVPDT1,DTVPDQ1)
+C
+C     Argument NK ajoute (jyg) = Niveau de depart de la
+C     convection
+C
+        PARAMETER (NA=60)
+        REAL GZ(ND),TPK(ND),CLW(ND)
+        REAL T(ND),RR(ND),RS(ND),TVP(ND),P(ND)
+        REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                   temperature wrt T1 and Q1
+C
+        REAL CLW_NEW(NA),QI(NA)
+        REAL DTPDT1(NA),DTPDQ1(NA)      ! Derivatives of parcel temperature
+C                                   wrt T1 and Q1
+ 
+C
+        LOGICAL ICE_CONV
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c sb        CPD=1005.7
+c sb      CPV=1870.0
+c sb        CL=4190.0
+c sb        CPVMCL=2320.0
+c sb        RV=461.5
+c sb        RD=287.04
+c sb        EPS=RD/RV
+c sb        ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CI=2090.0
+c sb      CPVMCL=CL-CPV
+c sb      CLMCI=CL-CI
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+c sb      ALF0=3.34E+05
+ 
+cccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+       GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CI = RCS
+       CPVMCL = CL-CPV
+       CLMCI = CL-CI
+       EPS = RD/RV
+       ALV0 = RLVTT
+       ALF0 = RLMLT ! (ALF0 = RLSTT-RLVTT)
+c 
+cccccccccccccccccccccc
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        ICB1=MAX(ICB,2)
+        ICB1=MIN(ICB,NL)
+C
+Cjyg1
+CC      CPP=CPD*(1.-RR(1))+RR(1)*CPV
+      CPP=CPD*(1.-RR(NK))+RR(NK)*CPV
+Cjyg2
+      CPINV=1./CPP
+Cjyg1
+C         ICB may be below condensation level
+CCC        DO 100 I=1,ICB1-1
+CCC         TPK(I)=T(1)-GZ(I)*CPINV
+CCC         TVP(I)=TPK(I)*(1.+RR(1)/EPS)
+        DO 50 I=1,ICB1
+         CLW(I)=0.0
+50      CONTINUE
+C
+        DO 100 I=NK,ICB1
+         TPK(I)=T(NK)-(GZ(I) - GZ(NK))*CPINV
+Cjyg1
+CCC         TVP(I)=TPK(I)*(1.+RR(NK)/EPS)
+         TVP(I)=TPK(I)*(1.+RR(NK)/EPS-RR(NK))
+Cjyg2
+         DTVPDT1(I) = 1.+RR(NK)/EPS-RR(NK)
+         DTVPDQ1(I) = TPK(I)*(1./EPS-1.)
+C
+Cjyg2
+ 
+  100   CONTINUE
+ 
+C
+C    ***  FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO    ***
+C
+Cjyg1
+CC        AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1)
+CC     $     +RR(1)*(ALV0-CPVMCL*(T(1)-273.15))
+        AH0=(CPD*(1.-RR(NK))+CL*RR(NK))*T(NK)
+     $     +RR(NK)*(ALV0-CPVMCL*(T(NK)-273.15)) + GZ(NK)
+Cjyg2
+C
+Cjyg1
+        IMIN = ICB1
+C         If ICB is below LCL, start loop at ICB+1
+        IF (PLCL .LT. P(ICB1)) IMIN = MIN(IMIN+1,NL)
+C
+CCC        DO 300 I=ICB1,NL
+        DO 300 I=IMIN,NL
+Cjyg2
+         ALV=ALV0-CPVMCL*(T(I)-273.15)
+         ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        RG=RS(I)
+        TG=T(I)
+C       S=CPD+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg1
+CC        S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I))
+        S=CPD*(1.-RR(NK))+CL*RR(NK)+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg2
+        S=1./S
+ 
+        DO 200 J=1,2
+Cjyg1
+CC         AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I)
+         AHG=CPD*TG+(CL-CPD)*RR(NK)*TG+ALV*RG+GZ(I)
+Cjyg2
+        TG=TG+S*(AH0-AHG)
+        TC=TG-273.15
+        DENOM=243.5+TC
+        DENOM=MAX(DENOM,1.0)
+C
+C       FORMULE DE BOLTON POUR PSAT
+C
+        ES=6.112*EXP(17.67*TC/DENOM)
+        RG=EPS*ES/(P(I)-ES*(1.-EPS))
+ 
+ 
+  200   CONTINUE
+ 
+Cjyg1
+CC        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1))
+        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(NK))
+Cjyg2
+C       TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD
+ 
+Cjyg1
+CC        CLW(I)=RR(1)-RG
+        CLW(I)=RR(NK)-RG
+Cjyg2
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+RG/EPS)
+        TVP(I)=TPK(I)*(1.+RG/EPS-RR(NK))
+Cjyg2
+C
+Cjyg1       Derivatives
+C
+        DTPDT1(I) = CPD*S
+        DTPDQ1(I) = ALV*S
+C
+         DTVPDT1(I) = DTPDT1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) )
+        DTVPDQ1(I) = DTPDQ1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) ) - TPK(I)
+C
+Cjyg2
+ 
+  300   CONTINUE
+C
+      ICE_CONV = .FALSE.
+
+      IF (ICE_CONV) THEN
+C
+CJAM
+C       RAJOUT DE LA PROCEDURE ICEFRAC
+C
+c sb        CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL)
+ 
+        DO 400 I=ICB1,NL
+        IF (T(I).LT.263.15) THEN
+        TG=TPK(I)
+        TC=TPK(I)-273.15
+        DENOM=243.5+TC
+        ES=6.112*EXP(17.67*TC/DENOM)
+        ALV=ALV0-CPVMCL*(T(I)-273.15)
+        ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        DO J=1,4
+        ESI=EXP(23.33086-(6111.72784/TPK(I))+0.15215*LOG(TPK(I)))
+        QSAT_NEW=EPS*ESI/(P(I)-ESI*(1.-EPS))
+CCC        SNEW= CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+        SNEW= CPD*(1.-RR(NK))+CL*RR(NK)
+     .        +ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+C
+        SNEW=1./SNEW
+        TPK(I)=TG+(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+c@$$        PRINT*,'################################'
+c@$$        PRINT*,TPK(I)
+c@$$        PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+        ENDDO
+CCC        CLW(I)=RR(1)-QSAT_NEW
+        CLW(I)=RR(NK)-QSAT_NEW
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS)
+        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS-RR(NK))
+Cjyg2
+        ELSE
+        CONTINUE
+        ENDIF
+ 
+  400   CONTINUE
+C
+      ENDIF
+C
+ 
+******************************************************
+** BK :  RAJOUT DE LA TEMPERATURE DES ASCENDANCES
+**   NON DILUES AU  NIVEAU KLEV = ND
+**   POSONS LE ENVIRON EGAL A CELUI DE KLEV-1
+********************************************************
+ 
+      TPK(NL+1)=TPK(NL)
+ 
+*******************************************************
+
+      RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+ 
+ 
+        RETURN
+        END
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
Index: LMDZ4/tags/LF_20080728/libf/phylmd/transp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/transp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/transp.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE transp (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c 
+       USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), e
+c     ------------------------------------------------------------------
+      DO i = 1, klon
+         utran_e(i) = 0.0
+         utran_q(i) = 0.0
+         vtran_e(i) = 0.0
+         vtran_q(i) = 0.0
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i)=utran_q(i)+ u(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/transp_lay.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/transp_lay.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/transp_lay.F	(revision 984)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE transp_lay (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon,klev), utran_q(klon,klev)
+      REAL vtran_e(klon,klev), vtran_q(klon,klev)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), esh
+c     ------------------------------------------------------------------
+      DO l = 1, klev
+      DO i = 1, klon
+         utran_e(i,l) = 0.0
+         utran_q(i,l) = 0.0
+         vtran_e(i,l) = 0.0
+         vtran_q(i,l) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         esh = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i,l)=utran_e(i,l)+ u(i,l)*esh*
+     .                (paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i,l)=utran_q(i,l)+ u(i,l)*q(i,l)
+     .                *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i,l)=vtran_e(i,l)+ v(i,l)*esh*
+     .                (paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i,l)=vtran_q(i,l)+ v(i,l)*q(i,l)
+     .                *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/undefSTD.F	(revision 984)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+      SUBROUTINE undefSTD(nlevSTD,itap,tlevSTD,
+     $           dtime,ecrit_hf,
+     $           oknondef,tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) 
+c          ou la variable tlevSTD est bien definie (.NE.1.E+20), 
+c et 
+c        * de la somme de tlevSTD => tsumSTD
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c        ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c        ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+c
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c variables Input
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime, ecrit_hf
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+c
+c variables Output
+      REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
+      LOGICAL oknondef(klon,klevSTD,nout)
+      REAL tnondef(klon,klevSTD,nout)
+c
+c calcul variables tous les pas de temps de la physique 
+c
+      DO k=1, nlevSTD
+       DO i=1, klon
+        IF(tlevSTD(i,k).EQ.1E+20) THEN
+         IF(oknondef(i,k,1)) THEN          
+          tnondef(i,k,1)=tnondef(i,k,1)+1.
+         ENDIF !oknondef(i,k)
+c
+         IF(oknondef(i,k,2)) THEN          
+          tnondef(i,k,2)=tnondef(i,k,2)+1.
+         ENDIF !oknondef(i,k)
+c
+        ELSE IF(tlevSTD(i,k).NE.1E+20) THEN
+         tsumSTD(i,k,1)=tsumSTD(i,k,1)+tlevSTD(i,k)
+         tsumSTD(i,k,2)=tsumSTD(i,k,2)+tlevSTD(i,k)
+        ENDIF 
+       ENDDO !i
+      ENDDO !k
+c
+c calcul variables toutes les 6h
+c
+      IF(MOD(itap,NINT(ecrit_hf/dtime)).EQ.0) THEN
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tlevSTD(i,k).EQ.1E+20) THEN
+          IF(oknondef(i,k,3)) THEN          
+           tnondef(i,k,3)=tnondef(i,k,3)+1.
+          ENDIF !oknondef(i,k)
+c
+         ELSE IF(tlevSTD(i,k).NE.1E+20) THEN
+         tsumSTD(i,k,3)=tsumSTD(i,k,3)+tlevSTD(i,k)
+         ENDIF 
+        ENDDO !i
+       ENDDO !k
+
+      ENDIF !MOD(itap,NINT(ecrit_hf/dtime)).EQ.0
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phylmd/ustarhb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/ustarhb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/ustarhb.F	(revision 984)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE ustarhb(knon,u,v,cd_m, ustar)
+      use dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+      REAL ustar(klon)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      DO i = 1, knon
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+c       print*,'Ust ',zxu,zxmod,taux,ustar(i)
+      ENDDO
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/vdif_kcay.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/vdif_kcay.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/vdif_kcay.F	(revision 984)
@@ -0,0 +1,743 @@
+!
+! $Header$
+!
+      SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c 
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),q2s(klon,klev+1)
+      REAL q2diag(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon)
+
+      integer l_mix,iii
+c.......................................................................
+c
+c nlay : nombre de couches        
+c nlev : nombre de niveaux
+c ngrid : nombre de points de grille       
+c unsdz : 1 sur l'epaisseur de couche
+c unsdzdec : 1 sur la distance entre le centre de la couche et le
+c            centre de la couche inferieure
+c q : echelle de vitesse au bas de chaque couche
+c     (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      INTEGER nlay,nlev,ngrid
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+      REAL q(klon,klev+1)
+
+c.......................................................................
+c
+c kmpre : km au debut du pas de temps
+c qcstat : q : solution stationnaire du probleme couple
+c          (valeur a la fin du pas de temps)
+c q2cstat : q2 : solution stationnaire du probleme couple
+c           (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL kmpre(klon,klev+1)
+      REAL qcstat
+      REAL q2cstat
+      real sss,sssq
+c.......................................................................
+c
+c long : longueur de melange calculee selon Blackadar
+c
+c.......................................................................
+      REAL long(klon,klev+1)
+c.......................................................................
+c
+c kmq3 : terme en q^3 dans le developpement de km
+c        (valeur au debut du pas de temps)
+c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c knq3 : terme en q^3 dans le developpement de kn
+c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+c          (valeur a la fin du pas de temps)
+c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c m : valeur a la fin du pas de temps
+c mpre : valeur au debut du pas de temps
+c m2 : valeur a la fin du pas de temps
+c n2 : valeur a la fin du pas de temps
+c 
+c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(klon,klev+1)
+      REAL mpre(klon,klev+1)
+      REAL m2(klon,klev+1)
+      REAL n2(klon,klev+1)
+c.......................................................................
+c
+c gn : intermediaire pour les coefficients de stabilite
+c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+c gnmax : borne superieure de gn (0.0233)
+c gninf : vrai si gn est en dessous de sa borne inferieure
+c gnsup : vrai si gn est en dessus de sa borne superieure
+c gm : drole d'objet bien utile
+c ri : nombre de Richardson
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c sm : coefficient de stabilite pour m
+c smq2 : premier terme du developement limite de sm en q2
+c
+c.......................................................................
+      REAL gn
+      REAL gnmin
+      REAL gnmax
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+c      REAL ri(klon,klev+1)
+      REAL sn(klon,klev+1)
+      REAL snq2(klon,klev+1)
+      REAL sm(klon,klev+1)
+      REAL smq2(klon,klev+1)
+c.......................................................................
+c
+c kappa : consatnte de Von Karman (0.4)
+c long00 : longueur de reference pour le calcul de long (160)
+c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+c cn1,cn2 : constantes pour sn
+c cm1,cm2,cm3,cm4 : constantes pour sm
+c
+c.......................................................................
+      REAL kappa
+      REAL long00
+      REAL a1,a2,b1,b2,c1
+      REAL cn1,cn2
+      REAL cm1,cm2,cm3,cm4
+c.......................................................................
+c
+c termq : termes en $q$ dans l'equation de q2
+c termq3 : termes en $q^3$ dans l'equation de q2
+c termqm2 : termes en $q*m^2$ dans l'equation de q2
+c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+c
+c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+c.......................................................................
+c
+c q2min : borne inferieure de q2
+c q2max : borne superieure de q2
+c
+c.......................................................................
+      REAL q2min
+      REAL q2max
+c.......................................................................
+c knmin : borne inferieure de kn
+c kmmin : borne inferieure de km
+c.......................................................................
+      REAL knmin
+      REAL kmmin
+c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+c.......................................................................
+      PARAMETER (kappa=0.4E+0)
+      PARAMETER (long00=160.E+0)
+c     PARAMETER (gnmin=-10.E+0)
+      PARAMETER (gnmin=-0.28)
+      PARAMETER (gnmax=0.0233E+0)
+      PARAMETER (a1=0.92E+0)
+      PARAMETER (a2=0.74E+0)
+      PARAMETER (b1=16.6E+0)
+      PARAMETER (b2=10.1E+0)
+      PARAMETER (c1=0.08E+0)
+      PARAMETER (knmin=1.E-5)
+      PARAMETER (kmmin=1.E-5)
+      PARAMETER (q2min=1.e-5)
+      PARAMETER (q2max=1.E+2)
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+c
+      PARAMETER (
+     &  cn1=a2*(1.E+0 -6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cn2=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1)
+     &          -3.E+0 *c1*(b2+6.E+0 *a1)))
+     &          )
+      PARAMETER (
+     &  cm3=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm4=-9.E+0 *a1*a2
+     &          )
+
+      logical first
+      save first
+      data first/.true./
+c$OMP THREADPRIVATE(first)
+c.......................................................................
+c  traitment des valeur de q2 en entree
+c.......................................................................
+c
+c   Initialisation de q2
+      nlay=klev
+      nlev=klev+1
+       
+      call yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar
+     s   ,l_mix)
+      if (first.and.1.eq.1) then
+      first=.false.
+      q2=q2diag
+      endif
+
+      DO ilev=1,nlev
+                                                      DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+                                                      ENDDO
+      ENDDO
+c
+                                                      DO igrid=1,ngrid 
+      tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+      q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+      q2(igrid,1)=amax1(q2(igrid,1),q2min)
+      q(igrid,1)=sqrt(q2(igrid,1))
+                                                      ENDDO
+c
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO igrid=1,ngrid 
+            zlev(igrid,nlev)=zlay(igrid,nlay)
+     &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+                                                      ENDDO            
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO ilay=1,nlay
+                                                      DO igrid=1,ngrid 
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+                                                      ENDDO
+      DO ilay=2,nlay
+                                                      DO igrid=1,ngrid 
+        unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+                                                      ENDDO
+c
+c.......................................................................
+c  le cisaillement et le gradient de temperature
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,1)=(unsdzdec(igrid,1)
+     &                   *u(igrid,1))**2
+     &                 +(unsdzdec(igrid,1)
+     &                   *v(igrid,1))**2
+      m(igrid,1)=sqrt(m2(igrid,1))
+      mpre(igrid,1)=m(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)
+     &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))
+     &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+c       n2(igrid,ilev)=0.
+c
+c --->
+c       on ne sais traiter que les cas stratifies. et l'ajustement
+c       convectif est cense faire en sorte que seul des configurations
+c       stratifiees soient rencontrees en entree de cette routine.
+c       mais, bon ... on sait jamais (meme on sait que n2 prends
+c       quelques valeurs negatives ... parfois) alors : 
+c<---
+c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)
+     &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2
+     &                   +(unsdzdec(igrid,ilev)
+     &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,nlev)=m2(igrid,nlev-1)
+      m(igrid,nlev)=m(igrid,nlev-1)
+      mpre(igrid,nlev)=m(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  calcul des fonctions de stabilite
+c.......................................................................
+c
+      if (l_mix.eq.4) then
+                                                      DO igrid=1,ngrid 
+         sqz(igrid)=1.e-10
+         sq(igrid)=1.e-10
+                                                      ENDDO
+         do ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+           zq=sqrt(q2(igrid,ilev))
+           sqz(igrid)
+     .     =sqz(igrid)+zq*zlev(igrid,ilev)
+     .     *(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+           sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+                                                      ENDDO
+         enddo
+                                                      DO igrid=1,ngrid 
+         long0(igrid)=0.2*sqz(igrid)/sq(igrid)
+                                                      ENDDO
+      else if (l_mix.eq.3) then
+         long0(igrid)=long00
+      endif
+
+c (abd 5 2)      print*,'LONG0=',long0
+
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        if (l_mix.ge.10) then
+            long(igrid,ilev)=l_mix
+        else
+           long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid))
+        endif
+        long(igrid,ilev)=max(min(long(igrid,ilev)
+     s    ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10)))
+     s    ,5.)
+
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * m2(igrid,ilev)
+c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)
+     &     *(1.E+0 +cm4*gn) )
+c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=
+     &     -gn
+     &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=
+     &     -gn
+     &     *( cm2*(1.E+0 +cm3*gn)
+     &           *(1.E+0 +cm4*gn)
+     &       -( cm3*(1.E+0 +cm4*gn)
+     &         +cm4*(1.E+0 +cm3*gn) )
+     &       *(cm1+cm2*gn)            )
+     &     /( (1.E+0 +cm3*gn)
+     &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+c
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c --->
+c       la decomposition de Taylor en q2 n'a de sens que
+c       dans les cas stratifies ou sn et sm sont quasi
+c       proportionnels a q2. ailleurs on laisse le meme
+c       algorithme car l'ajustement convectif fait le travail.
+c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+c       signe : dans ces cas, on ne fait pas la decomposition.
+c<---
+c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)
+     &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)
+     &      smq2(igrid,ilev)=0.E+0
+c
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde       print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+c.......................................................................
+c  calcul de km et kn au debut du pas de temps
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      kmpre(igrid,1)=km(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+      kmpre(igrid,nlev)=km(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  boucle sur les niveaux 2 a nlev-1
+c.......................................................................
+c
+c---->
+      DO 10001 ilev=2,nlev-1
+c---->
+      DO 10002 igrid=1,ngrid 
+c
+c.......................................................................
+c
+c  calcul des termes sources et puits de l'equation de q2
+c  ------------------------------------------------------
+c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)
+     &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)
+     &                                    /sm(igrid,ilev)
+c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2
+     &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+     &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2
+     &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+c 
+        termq=termq
+     &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)
+     &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3
+     &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+c
+        termq3=termq3
+     &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+c
+c.......................................................................
+c
+c  resolution stationnaire couplee avec le gradient de vitesse local
+c  -----------------------------------------------------------------
+c
+c  -----{on cherche le cisaillement qui annule l'equation de q^2
+c        supposee en q3}
+c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)
+     &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+
+c  abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)
+     &              *cd(igrid)
+     &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)
+     &                -mcstat/unsdzdec(igrid,ilev)
+     &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)
+     &                          *mpre(igrid,ilev-1) )
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat
+     &      /( sm(igrid,ilev)/q2(igrid,ilev) )
+     &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+c
+c.......................................................................
+c
+c  choix de la solution finale
+c  ---------------------------
+c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+c abd       if(ilev.le.57.and.ilev.ge.37) then
+c           print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
+c     s     'N2=',n2(igrid,ilev)
+c abd       endif
+          m2(igrid,ilev)=m2cstat
+c
+c --->
+c       pour des raisons simples q2 est minore 
+c<---
+c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+c
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sm(igrid,ilev)
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c
+c.......................................................................
+c
+10002 CONTINUE
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+c     kn(igrid,1)=cd(igrid)
+c     km(igrid,1)=cd(igrid)
+      q2(igrid,nlev)=q2(igrid,nlev-1)
+      q(igrid,nlev)=q(igrid,nlev-1)
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+                                                      ENDDO
+c
+c  CALCUL DE LA DIFFUSION VERTICALE DE Q2
+      if (1.eq.1) then
+
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+c        print*,'Q2moy avant',sssq/sss
+c       print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
+c       print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
+c   ! C'est quoi ca qu'etait dans l'original???
+c       do igrid=1,ngrid
+c          q2(igrid,1)=10.
+c       enddo
+c        q2s=q2
+c       do iii=1,10
+c       call vdif_q2(dt,g,rconst,plev,temp,km,q2)
+c       do ilev=1,klev+1
+c          write(iii+49,*) q2(1,ilev),zlev(1,ilev)
+c       enddo
+c       enddo
+c       stop
+c       do ilev=1,klev
+c          print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
+c       enddo
+c        q2s=q2-q2s
+c       do ilev=1,klev
+c          print*,q2s(1,ilev),zlev(1,ilev)
+c       enddo
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+        print*,'Q2moy apres',sssq/sss
+c
+c
+        do ilev=1,nlev
+           do igrid=1,ngrid
+              q2(igrid,ilev)=max(q2(igrid,ilev),q2min)
+              q(igrid,ilev)=sqrt(q2(igrid,ilev))
+
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde      print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+c
+           enddo
+        enddo
+c       print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
+
+      endif
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phylmd/wake.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/wake.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/wake.F	(revision 984)
@@ -0,0 +1,2334 @@
+      Subroutine WAKE (p,ph,ppi,dtime,sigd_con
+     :                ,te0,qe0,omgb
+     :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     :                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     o                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl
+     o                ,dtls,dqls
+     o                ,ktopw,omgbdth,dp_omgb,wdens
+     o                ,tu,qu
+     o                ,dtKE,dqKE
+     o                ,dtPBL,dqPBL
+     o                ,omg,dp_deltomg,spread
+     o                ,Cstar,d_deltat_gw
+     o                ,d_deltatw2,d_deltaqw2)
+
+***************************************************************
+*                                                             *
+* WAKE                                                        *
+*      retour a un Pupper fixe                                *
+*                                                             *
+* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+* modified by :   ROEHRIG Romain        01/29/2007            *
+***************************************************************
+c
+      use dimphy
+      IMPLICIT none
+c============================================================================
+C
+C
+C   But : Decrire le comportement des poches froides apparaissant dans les
+C        grands systemes convectifs, et fournir l'energie disponible pour
+C        le declenchement de nouvelles colonnes convectives.
+C
+C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
+C                      deltaqw    : ecart d'humidite wake-undisturbed area
+C                      sigmaw     : fraction d'aire occupee par la poche.
+C
+C   Variable de sortie : 
+c
+c			 wape : WAke Potential Energy
+c                        fip  : Front Incident Power (W/m2) - ALP
+c                        gfl  : Gust Front Length per unit area (m-1)
+C                        dtls : large scale temperature tendency due to wake
+C                        dqls : large scale humidity tendency due to wake
+C                        hw   : hauteur de la poche
+C                     dp_omgb : vertical gradient of large scale omega
+C                      omgbdth: flux of Delta_Theta transported by LS omega
+C                      dtKE   : differential heating (wake - unpertubed)
+C                      dqKE   : differential moistening (wake - unpertubed)
+C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+C                 dp_deltomg  : vertical gradient of omg (s-1)
+C                     spread  : spreading term in dt_wake and dq_wake
+C                 deltatw     : updated temperature difference (T_w-T_u).
+C                 deltaqw     : updated humidity difference (q_w-q_u).
+C                 sigmaw      : updated wake fractional area.
+C                 d_deltat_gw : delta T tendency due to GW
+c
+C   Variables d'entree : 
+c
+c		         aire : aire de la maille
+c			 te0  : temperature dans l'environnement  (K)
+C                        qe0  : humidite dans l'environnement     (kg/kg)
+C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
+C                        dtdwn: source de chaleur due aux descentes (K/s)
+C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
+C			 dta  : source de chaleur due courants satures et detrain  (K/s)
+C			 dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+C                        amdwn: flux de masse total des descentes, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        amup : flux de masse total des ascendances, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        p    : pressions aux milieux des couches (Pa)
+C                        ph   : pressions aux interfaces (Pa)
+C                        ppi  : (p/p_0)**kapa (adim)
+C                        dtime: increment temporel (s)
+c
+C   Variables internes :
+c
+c			 rhow : masse volumique de la poche froide
+C                        rho  : environment density at P levels
+C                        rhoh : environment density at Ph levels
+C                        te   : environment temperature | may change within
+C                        qe   : environment humidity    | sub-time-stepping
+C                        the  : environment potential temperature
+C                        thu  : potential temperature in undisturbed area
+C                        tu   :  temperature  in undisturbed area
+C                        qu   : humidity in undisturbed area
+C                      dp_omgb: vertical gradient og LS omega
+C                      omgbw  : wake average vertical omega
+C                     dp_omgbw: vertical gradient of omgbw
+C                      omgbdq : flux of Delta_q transported by LS omega
+C                        dth  : potential temperature diff. wake-undist.
+C                        th1  : first pot. temp. for vertical advection (=thu)
+C                        th2  : second pot. temp. for vertical advection (=thw)
+C                        q1   : first humidity for vertical advection
+C                        q2   : second humidity for vertical advection
+C                     d_deltatw   : terme de redistribution pour deltatw
+C                     d_deltaqw   : terme de redistribution pour deltaqw
+C                      deltatw0   : deltatw initial
+C                      deltaqw0   : deltaqw initial
+C                      hw0    : hw initial
+C                      sigmaw0: sigmaw initial
+C                      amflux : horizontal mass flux through wake boundary
+C                      wdens  : number of wakes per unit area (3D) or per
+C                               unit length (2D)
+C                      Tgw    : 1 sur la période de onde de gravité
+c                      Cgw    : vitesse de propagation de onde de gravité
+c                      LL     : distance entre 2 poches
+
+c-------------------------------------------------------------------------
+c          Déclaration de variables
+c-------------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "iniprint.h"
+
+c Arguments en entree
+c--------------------
+
+      REAL, dimension(klon,klev) :: p, ppi
+      REAL, dimension(klon,klev+1) :: ph, omgb
+      REAL dtime
+      REAL, dimension(klon,klev) :: te0,qe0
+      REAL, dimension(klon,klev) :: dtdwn, dqdwn
+      REAL, dimension(klon,klev) :: wdtPBL,wdqPBL
+      REAL, dimension(klon,klev) :: udtPBL,udqPBL
+      REAL, dimension(klon,klev) :: amdwn, amup
+      REAL, dimension(klon,klev) :: dta, dqa
+      REAL, dimension(klon) :: sigd_con
+
+c Sorties
+c--------
+
+      REAL, dimension(klon,klev) :: deltatw, deltaqw, dth
+      REAL, dimension(klon,klev) :: tu, qu
+      REAL, dimension(klon,klev) :: dtls, dqls
+      REAL, dimension(klon,klev) :: dtKE, dqKE
+      REAL, dimension(klon,klev) :: dtPBL, dqPBL
+      REAL, dimension(klon,klev) :: spread
+      REAL, dimension(klon,klev) :: d_deltatgw
+      REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2
+      REAL, dimension(klon,klev+1) :: omgbdth, omg
+      REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg
+      REAL, dimension(klon,klev) :: d_deltat_gw
+      REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar
+      INTEGER, dimension(klon) :: ktopw
+
+c Variables internes
+c-------------------
+
+c Variables à fixer
+      REAL ALON
+      REAL coefgw
+      REAL :: wdens0, wdens
+      REAL stark
+      REAL alpk
+      REAL delta_t_min
+      REAL Pupper
+      INTEGER nsub
+      REAL dtimesub
+      REAL sigmad, hwmin
+cIM 080208
+      LOGICAL, dimension(klon) :: gwake
+
+c Variables de sauvegarde
+      REAL, dimension(klon,klev) :: deltatw0
+      REAL, dimension(klon,klev) :: deltaqw0
+      REAL, dimension(klon,klev) :: te, qe
+      REAL, dimension(klon) :: sigmaw0, sigmaw1
+
+c Variables pour les GW
+      REAL, DIMENSION(klon) :: LL
+      REAL, dimension(klon,klev) :: N2
+      REAL, dimension(klon,klev) :: Cgw
+      REAL, dimension(klon,klev) :: Tgw
+
+c Variables liées au calcul de hw
+      REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new
+      REAL, DIMENSION(klon) :: sum_dth
+      REAL, DIMENSION(klon) :: dthmin
+      REAL, DIMENSION(klon) :: z, dz, hw0
+      INTEGER, DIMENSION(klon) :: ktop, kupper
+
+c Autres variables internes
+      INTEGER isubstep, k, i
+
+      REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu
+      REAL, DIMENSION(klon) :: sum_dq, sum_rho
+      REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn
+      REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu
+      REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho
+      REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn
+
+      REAL, DIMENSION(klon,klev) :: rho, rhow
+      REAL, DIMENSION(klon,klev+1) :: rhoh
+      REAL, DIMENSION(klon,klev) :: rhow_moyen
+      REAL, DIMENSION(klon,klev) :: zh
+      REAL, DIMENSION(klon,klev+1) :: zhh
+      REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2
+
+      REAL, DIMENSION(klon,klev) :: the, thu
+
+      REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw
+
+      REAL, DIMENSION(klon,klev+1) :: omgbw 
+      REAL, DIMENSION(klon) :: omgtop
+      REAL, DIMENSION(klon,klev) :: dp_omgbw
+      REAL, DIMENSION(klon) :: ztop, dztop
+      REAL, DIMENSION(klon,klev) :: alpha_up
+      
+      REAL, dimension(klon) :: RRe1, RRe2
+      REAL :: RRd1, RRd2
+      REAL, DIMENSION(klon,klev) :: Th1, Th2, q1, q2
+      REAL, DIMENSION(klon,klev) :: D_Th1, D_Th2, D_dth
+      REAL, DIMENSION(klon,klev) :: D_q1, D_q2, D_dq
+      REAL, DIMENSION(klon,klev) :: omgbdq
+
+      REAL, dimension(klon) :: ff, gg
+      REAL, dimension(klon) :: wape2, Cstar2, heff
+
+      REAL, DIMENSION(klon,klev) :: Crep
+      REAL Crep_upper, Crep_sol
+
+C-------------------------------------------------------------------------
+c         Initialisations
+c-------------------------------------------------------------------------
+
+c      print*, 'wake initialisations'
+
+c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
+c-------------------------------------------------------------------------
+
+      DATA sigmad, hwmin /.02,10./
+
+C Longueur de maille (en m)
+c-------------------------------------------------------------------------
+
+c      ALON = 3.e5
+      ALON = 1.e6
+
+
+C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+c
+c      coefgw : Coefficient pour les ondes de gravité
+c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+c       wdens : Densité de poche froide par maille
+c-------------------------------------------------------------------------
+
+      coefgw=10
+c      coefgw=1
+c      wdens0 = 1.0/(alon**2)   
+      wdens = 1.0/(alon**2)       
+      stark = 0.50
+cCRtest
+      alpk=0.1
+c      alpk = 1.0 
+c      alpk = 0.5
+c      alpk = 0.05
+      Crep_upper=0.9
+      Crep_sol=1.0
+
+
+C Minimum value for |T_wake - T_undist|. Used for wake top definition
+c-------------------------------------------------------------------------
+
+      delta_t_min = 0.2
+
+C 1. - Save initial values and initialize tendencies
+C --------------------------------------------------
+
+      DO k=1,klev
+      DO i=1, klon
+	deltatw0(i,k) = deltatw(i,k)
+	deltaqw0(i,k)= deltaqw(i,k)
+	te(i,k) = te0(i,k)
+	qe(i,k) = qe0(i,k)
+	dtls(i,k) = 0.
+	dqls(i,k) = 0.
+        d_deltat_gw(i,k)=0.
+!IM 060508 beg
+        d_deltatw2(i,k)=0.
+        d_deltaqw2(i,k)=0.
+!IM 060508 end
+      ENDDO
+      ENDDO
+c      sigmaw1=sigmaw
+c      IF (sigd_con.GT.sigmaw1) THEN
+c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+c      ENDIF
+      DO i=1, klon
+cc      sigmaw(i) = amax1(sigmaw(i),sigd_con(i))
+      sigmaw(i) = amax1(sigmaw(i),sigmad)
+      sigmaw(i) = amin1(sigmaw(i),0.99)
+      sigmaw0(i) = sigmaw(i)
+      ENDDO
+C
+C
+C 2. - Prognostic part
+C --------------------
+C
+C
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      DO i=1, klon
+      z(i) = 0.
+      ktop(i)=0
+      kupper(i) = 0
+      sum_thu(i) = 0.
+      sum_tu(i) = 0.
+      sum_qu(i) = 0.
+      sum_thvu(i) = 0.
+      sum_dth(i) = 0.
+      sum_dq(i) = 0.
+      sum_rho(i) = 0.
+      sum_dtdwn(i) = 0.
+      sum_dqdwn(i) = 0.
+
+      av_thu(i) = 0.
+      av_tu(i) =0.
+      av_qu(i) =0.
+      av_thvu(i) = 0.
+      av_dth(i) = 0.
+      av_dq(i) = 0.
+      av_rho(i) =0.
+      av_dtdwn(i) =0.
+      av_dqdwn(i) = 0.
+      ENDDO
+c
+c Distance between wakes
+       DO i = 1,klon
+        LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens)
+       ENDDO
+C Potential temperatures and humidity
+c----------------------------------------------------------
+      DO k =1,klev
+       DO i=1, klon 
+        rho(i,k) = p(i,k)/(rd*te(i,k))
+        IF(k .eq. 1) THEN
+          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
+          zhh(i,k)=0
+        ELSE
+          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
+          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
+        ENDIF
+        the(i,k) = te(i,k)/ppi(i,k)
+        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
+        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
+        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
+        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+       ENDDO
+      ENDDO
+        
+      DO k = 1, klev-1
+      DO i=1, klon 
+        IF(k.eq.1) THEN
+          N2(i,k)=0
+        ELSE
+          N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)-
+     $            the(i,k-1))/(p(i,k+1)-p(i,k-1)))
+        ENDIF
+        ZH(i,k)=(zhh(i,k)+zhh(i,k+1))/2
+
+        Cgw(i,k)=sqrt(N2(i,k))*ZH(i,k)
+        Tgw(i,k)=coefgw*Cgw(i,k)/LL(i)
+      ENDDO
+      ENDDO
+
+      DO i=1, klon
+      N2(i,klev)=0
+      ZH(i,klev)=0
+      Cgw(i,klev)=0
+      Tgw(i,klev)=0
+      ENDDO
+
+c  Calcul de la masse volumique moyenne de la colonne   (bdlmd)
+c-----------------------------------------------------------------
+
+      DO k=1,klev
+       DO i=1, klon
+        epaisseur1(i,k)=0.
+        epaisseur2(i,k)=0.
+       ENDDO
+      ENDDO
+
+      DO i=1, klon
+      epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
+      epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
+      rhow_moyen(i,1) = rhow(i,1)
+      ENDDO
+
+      DO k = 2, klev
+      DO i=1, klon
+        epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1.
+        epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k)
+        rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+
+     $                 rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k)
+      ENDDO
+      ENDDO
+
+C
+C Choose an integration bound well above wake top
+c-----------------------------------------------------------------
+c
+C       Pupper = 50000.  ! melting level
+       Pupper = 60000.
+c       Pupper = 80000.  ! essais pour case_e
+C
+C    Determine Wake top pressure (Ptop) from buoyancy integral
+C    --------------------------------------------------------
+c
+c-1/ Pressure of the level where dth becomes less than delta_t_min.
+
+      DO i=1,klon
+      ptop_provis(i)=ph(i,1)
+      ENDDO
+      DO k= 2,klev
+      DO i=1,klon
+c
+cIM v3JYG; ptop_provis(i).LT. ph(i,1)
+c
+        IF (dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min .and.
+     $      ptop_provis(i).EQ. ph(i,1)) THEN
+          ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
+     $          (dth(i,k) - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+
+c-2/ dth integral
+
+      DO i=1,klon
+      sum_dth(i) = 0.
+      dthmin(i) = -delta_t_min
+      z(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .gt. 0) THEN
+          z(i) = z(i)+dz(i)
+          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+          dthmin(i) = amin1(dthmin(i),dth(i,k))
+        ENDIF
+      ENDDO
+      ENDDO
+
+c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      DO i=1,klon
+      hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
+      hw0(i) = amax1(hwmin,hw0(i))
+      ENDDO
+
+c-4/ now, get Ptop
+
+      DO i=1,klon
+      z(i) = 0.
+      ptop(i) = ph(i,1)
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i))
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+
+
+C-5/ Determination de ktop et kupper
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
+        IF (ph(i,k+1) .lt. pupper) kupper(i)=k
+      ENDDO
+      ENDDO
+
+c-6/ Correct ktop and ptop
+
+      DO i = 1,klon
+        ptop_new(i)=ptop(i)
+      ENDDO
+      DO k= klev,2,-1
+      DO i=1,klon
+        IF (k .LE. ktop(i) .and.
+     $      ptop_new(i) .EQ. ptop(i) .and.
+     $      dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min) THEN
+          ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
+     $          (dth(i,k) - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+        ptop(i) = ptop_new(i)
+      ENDDO
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
+      ENDDO
+      ENDDO
+c
+c-5/ Set deltatw & deltaqw to 0 above kupper
+c
+      DO k = 1,klev
+      DO i=1,klon
+       IF (k.GE. kupper(i)) THEN
+        deltatw(i,k) = 0.
+        deltaqw(i,k) = 0.
+       ENDIF
+      ENDDO
+      ENDDO
+c
+C
+C Vertical gradient of LS omega
+C
+      DO k = 1,klev
+      DO i=1,klon
+       IF (k.LE. kupper(i)) THEN
+        dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+C
+C Integrals (and wake top level number)
+C --------------------------------------
+C
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+      z(i) = 1.
+      dz(i) = 1.
+      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+      sum_dth(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+        hw0(i) = z(i)
+      ENDDO
+c
+C
+C 2.1 - WAPE and mean forcing computation
+C ---------------------------------------
+C
+C ---------------------------------------
+C
+C Means
+
+      DO i=1,klon
+      av_thu(i) = sum_thu(i)/hw0(i)
+      av_tu(i) = sum_tu(i)/hw0(i)
+      av_qu(i) = sum_qu(i)/hw0(i)
+      av_thvu(i) = sum_thvu(i)/hw0(i)
+c      av_thve = sum_thve/hw0
+      av_dth(i) = sum_dth(i)/hw0(i)
+      av_dq(i) = sum_dq(i)/hw0(i)
+      av_rho(i) = sum_rho(i)/hw0(i)
+      av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+      av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+      wape(i) = - rg*hw0(i)*(av_dth(i)
+     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
+     $     av_dq(i) ))/av_thvu(i)
+      ENDDO
+C
+C 2.2 Prognostic variable update
+C ------------------------------
+C
+C Filter out bad wakes
+
+      DO k = 1,klev
+       DO i=1,klon
+        IF ( wape(i) .LT. 0.) THEN
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+c
+      DO i=1,klon
+      IF ( wape(i) .LT. 0.) THEN
+        wape(i) = 0.
+        Cstar(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = amax1(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        Cstar(i) = stark*sqrt(2.*wape(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+C
+CC -----------------------------------------------------------------
+C    Sub-time-stepping
+C    -----------------
+C
+      nsub=10
+      dtimesub=dtime/nsub
+c
+c------------------------------------------------------------
+      DO isubstep = 1,nsub
+c------------------------------------------------------------
+      DO i=1,klon
+        gfl(i) = 2.*sqrt(3.14*wdens*sigmaw(i))
+      ENDDO
+      DO i=1,klon
+        sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
+        sigmaw(i) =amin1(sigmaw(i),0.99)     !!!!!!!!
+c        wdens = wdens0/(10.*sigmaw)
+c        sigmaw =max(sigmaw,sigd_con)
+c        sigmaw =max(sigmaw,sigmad)
+      ENDDO
+C
+C
+c calcul de la difference de vitesse verticale poche - zone non perturbee
+cIM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
+cIM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
+cIM 060208 au niveau k=1..?
+      dp_deltomg(1:klon,1:klev)=0.
+      DO k= 1,klev+1
+      DO i = 1,klon
+        omg(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+        z(i)= 0.
+        omg(i,1) = 0.
+        dp_deltomg(i,1) = -(gfl(i)*Cstar(i))/(sigmaw(i) * (1-sigmaw(i)))
+      ENDDO
+c
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( k .LE. ktop(i)) THEN
+          dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*rg)
+          z(i) = z(i)+dz(i)
+          dp_deltomg(i,k)= dp_deltomg(i,1)
+          omg(i,k)= dp_deltomg(i,1)*z(i)
+       ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+        dztop(i)=-(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*rg)
+        ztop(i) = z(i)+dztop(i)
+        omgtop(i)=dp_deltomg(i,1)*ztop(i)
+      ENDDO
+c
+c        -----------------
+c        From m/s to Pa/s
+c        -----------------
+c
+       DO i=1,klon
+        omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i)
+        dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1))
+       ENDDO
+c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( k .LE. ktop(i)) THEN
+          omg(i,k) = - rho(i,k)*rg*omg(i,k)
+          dp_deltomg(i,k) = dp_deltomg(i,1)
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c   raccordement lineaire de omg de ptop a pupper
+
+      DO i=1,klon
+      IF (kupper(i) .GT. ktop(i)) THEN
+        omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)
+     $                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
+        dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/
+     $                     (ptop(i)-pupper)
+      ENDIF
+      ENDDO
+c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( k .GT. ktop(i) .AND. k .LE. kupper(i)) THEN
+          dp_deltomg(i,k) = dp_deltomg(i,kupper(i))
+          omg(i,k) = omgtop(i)+(ph(i,k)-ptop(i))*dp_deltomg(i,kupper(i))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c--    Compute wake average vertical velocity omgbw
+c
+c
+      DO k = 1,klev+1
+      DO i=1,klon
+        omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k)
+      ENDDO
+      ENDDO
+c--    and its vertical gradient dp_omgbw
+c
+      DO k = 1,klev
+      DO i=1,klon
+        dp_omgbw(i,k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
+      ENDDO
+      ENDDO
+C
+c--    Upstream coefficients for omgb velocity
+c--    (alpha_up(k) is the coefficient of the value at level k)
+c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
+      DO k = 1,klev
+      DO i=1,klon
+       alpha_up(i,k) = 0.
+       IF (omgb(i,k) .GT. 0.) alpha_up(i,k) = 1.
+      ENDDO
+      ENDDO
+
+c  Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+      DO i=1,klon
+        RRe1(i) = 1.-sigmaw(i)
+        RRe2(i) = sigmaw(i)
+      ENDDO
+      RRd1 = -1.
+      RRd2 = 1.
+c
+c--    Get [Th1,Th2], dth and [q1,q2]
+c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF(k .LE. kupper(i)+1) THEN
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+        Th1(i,k) = the(i,k) - sigmaw(i)     *dth(i,k)   ! undisturbed area
+        Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k)   ! wake
+        q1(i,k) = qe(i,k) - sigmaw(i)     *deltaqw(i,k) ! undisturbed area
+        q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake
+       ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+       D_Th1(i,1) = 0.
+       D_Th2(i,1) = 0.
+       D_dth(i,1) = 0.
+       D_q1(i,1) = 0.
+       D_q2(i,1) = 0.
+       D_dq(i,1) = 0.
+      ENDDO
+
+      DO k= 2,klev
+      DO i = 1,klon
+       IF(k .LE. kupper(i)+1) THEN
+        D_Th1(i,k) = Th1(i,k-1)-Th1(i,k)
+        D_Th2(i,k) = Th2(i,k-1)-Th2(i,k)
+        D_dth(i,k) = dth(i,k-1)-dth(i,k)
+        D_q1(i,k) = q1(i,k-1)-q1(i,k)
+        D_q2(i,k) = q2(i,k-1)-q2(i,k)
+        D_dq(i,k) = deltaqw(i,k-1)-deltaqw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+        omgbdth(i,1) = 0.
+        omgbdq(i,1) = 0.
+      ENDDO
+
+      DO k= 2,klev
+      DO i = 1,klon
+       IF(k .LE. kupper(i)+1) THEN  !   loop on interfaces
+        omgbdth(i,k) = omgb(i,k)*(    dth(i,k-1) -     dth(i,k))
+        omgbdq(i,k)  = omgb(i,k)*(deltaqw(i,k-1) - deltaqw(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c-----------------------------------------------------------------
+      DO k= 1,klev
+      DO i = 1,klon
+       IF(k .LE. kupper(i)-1) THEN
+c-----------------------------------------------------------------
+c
+c   Compute redistribution (advective) term
+c
+         d_deltatw(i,k) =
+     $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
+     $       RRd1*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
+     $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1)
+     $      -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)*
+     $      omgbdth(i,k+1))*ppi(i,k)
+c         print*,'d_deltatw=',d_deltatw(i,k)
+c
+         d_deltaqw(i,k) =
+     $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
+     $       RRd1*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
+     $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1)
+     $      -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)*
+     $      omgbdq(i,k+1))
+c         print*,'d_deltaqw=',d_deltaqw(i,k)
+c
+c   and increment large scale tendencies
+c
+         dtls(i,k) = dtls(i,k) +
+     $               dtimesub*(
+     $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
+     $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) )
+     $               /(Ph(i,k)-Ph(i,k+1))
+     $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*dp_deltomg(i,k)
+     $                      )*ppi(i,k)
+c         print*,'dtls=',dtls(i,k)
+c
+         dqls(i,k) = dqls(i,k) +
+     $               dtimesub*(
+     $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
+     $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) )
+     $               /(Ph(i,k)-Ph(i,k+1))
+     $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*dp_deltomg(i,k)
+     $                      )
+c         print*,'dqls=',dqls(k)
+       ENDIF
+c-------------------------------------------------------------------
+      ENDDO
+      ENDDO
+c------------------------------------------------------------------
+C
+C   Increment state variables
+
+      DO k= 1,klev
+      DO i = 1,klon
+       IF(k .LE. kupper(i)-1) THEN
+c
+c Coefficient de répartition
+
+        Crep(i,k)=Crep_sol*(ph(i,kupper(i))-ph(i,k))/(ph(i,kupper(i))
+     $          -ph(i,1))
+        Crep(i,k)=Crep(i,k)+Crep_upper*(ph(i,1)-ph(i,k))/(p(i,1)-
+     $          ph(i,kupper(i)))
+        
+
+c Reintroduce compensating subsidence term.
+
+c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+c     .                   /(1-sigmaw)
+c
+c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+c     .                   /(1-sigmaw)
+
+        dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i)))
+        dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i)))
+c        print*,'dtKE=',dtKE(k)
+c        print*,'dqKE=',dqKE(k)
+c
+        dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i)))
+        dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i)))
+c
+        spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
+     $  sigmaw(i)
+
+
+c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
+
+        d_deltat_gw(i,k)=d_deltat_gw(i,k)-Tgw(i,k)*deltatw(i,k)* 
+     $  dtimesub
+        ff(i)=d_deltatw(i,k)/dtimesub
+
+c Sans GW
+c
+c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) 
+c
+c GW formule 1
+c
+c        deltatw(k) = deltatw(k)+dtimesub*
+c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+c
+c GW formule 2
+
+        IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN
+          deltatw(i,k) = deltatw(i,k)+dtimesub*
+     $          (ff(i)+dtKE(i,k)+dtPBL(i,k) 
+     $          - spread(i,k)*deltatw(i,k)-Tgw(i,k)*deltatw(i,k))
+        ELSE
+           deltatw(i,k) = deltatw(i,k)+1/Tgw(i,k)*(1-exp(-dtimesub*
+     $          Tgw(i,k)))*
+     $          (ff(i)+dtKE(i,k)+dtPBL(i,k)
+     $          - spread(i,k)*deltatw(i,k)-Tgw(i,k)*deltatw(i,k))
+        ENDIF
+   
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+
+        gg(i)=d_deltaqw(i,k)/dtimesub
+
+       deltaqw(i,k) = deltaqw(i,k) +
+     $         dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k) - spread(i,k)*
+     $         deltaqw(i,k))
+
+       d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
+       d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+
+C   And update large scale variables
+cIM 060208 manque DO i + remplace DO k=1,kupper(i)
+cIM 060208     DO k = 1,kupper(i)
+      DO k= 1,klev
+      DO i = 1,klon
+       IF(k .LE. kupper(i)) THEN
+        te(i,k) = te0(i,k) + dtls(i,k)
+        qe(i,k) = qe0(i,k) + dqls(i,k)
+        the(i,k) = te(i,k)/ppi(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+c
+C
+c     Determine Ptop from buoyancy integral
+c     ---------------------------------------
+c
+c-     1/ Pressure of the level where dth changes sign.
+c
+      DO i=1,klon
+      Ptop_provis(i)=ph(i,1)
+      ENDDO
+c
+      DO k= 2,klev
+      DO i=1,klon
+        IF (Ptop_provis(i) .EQ. ph(i,1) .AND.
+     $      dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min) THEN
+          Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
+     $          - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c-     2/ dth integral
+c
+      DO i=1,klon
+       sum_dth(i) = 0.
+       dthmin(i) = -delta_t_min
+       z(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         dthmin(i) = amin1(dthmin(i),dth(i,k))
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c-     3/ height of triangle with area= sum_dth and base = dthmin
+
+      DO i=1,klon
+       hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
+       hw(i) = amax1(hwmin,hw(i))
+      ENDDO
+c
+c-     4/ now, get Ptop
+c
+      DO i=1,klon
+       ktop(i) = 0
+       z(i)=0.
+      ENDDO
+c
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i))
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i)
+         ktop(i) = k
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c      4.5/Correct ktop and ptop
+c
+      DO i=1,klon
+        Ptop_new(i)=ptop(i)
+      ENDDO
+c
+      DO k= klev,2,-1
+      DO i=1,klon
+cIM v3JYG; IF (k .GE. ktop(i)
+       IF (k .LE. ktop(i) .AND.
+     $      ptop_new(i) .EQ. ptop(i) .AND.
+     $      dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min) THEN
+          Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
+     $          - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c
+      DO i=1,klon
+      ptop(i) = ptop_new(i)
+      ENDDO
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k
+      ENDDO
+      ENDDO
+c
+c      5/ Set deltatw & deltaqw to 0 above kupper
+c
+      DO k = 1,klev
+      DO i=1,klon
+        IF (k .GE. kupper(i)) THEN
+         deltatw(i,k) = 0.
+         deltaqw(i,k) = 0.
+        ENDIF
+      ENDDO
+      ENDDO
+c
+C
+       ENDDO      ! end sub-timestep loop
+C
+C -----------------------------------------------------------------
+c   Get back to tendencies per second
+c
+      DO k = 1,klev
+      DO i=1,klon
+        IF (k .LE. kupper(i)-1) THEN
+         dtls(i,k) = dtls(i,k)/dtime
+         dqls(i,k) = dqls(i,k)/dtime
+         d_deltatw2(i,k)=d_deltatw2(i,k)/dtime
+         d_deltaqw2(i,k)=d_deltaqw2(i,k)/dtime
+         d_deltat_gw(i,k) = d_deltat_gw(i,k)/dtime
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c
+c----------------------------------------------------------
+c   Determine wake final state; recompute wape, cstar, ktop;
+c   filter out bad wakes.
+c----------------------------------------------------------
+c
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      DO i=1,klon
+        z(i) = 0.
+        sum_thu(i) = 0.
+        sum_tu(i) = 0.
+        sum_qu(i) = 0.
+        sum_thvu(i) = 0.
+        sum_dth(i) = 0.
+        sum_dq(i) = 0.
+        sum_rho(i) = 0.
+        sum_dtdwn(i) = 0.
+        sum_dqdwn(i) = 0.
+
+        av_thu(i) = 0.
+        av_tu(i) =0.
+        av_qu(i) =0.
+        av_thvu(i) = 0.
+        av_dth(i) = 0.
+        av_dq(i) = 0.
+        av_rho(i) =0.
+        av_dtdwn(i) =0.
+        av_dqdwn(i) = 0.
+      ENDDO
+C Potential temperatures and humidity
+c----------------------------------------------------------
+
+      DO k =1,klev
+      DO i=1,klon
+        rho(i,k) = p(i,k)/(rd*te(i,k))
+        IF(k .eq. 1) THEN
+          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
+          zhh(i,k)=0
+        ELSE
+          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
+          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
+        ENDIF
+        the(i,k) = te(i,k)/ppi(i,k)
+        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
+        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
+        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
+        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+      ENDDO
+      ENDDO
+
+C Integrals (and wake top level number)
+C -----------------------------------------------------------
+
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+        z(i) = 1.
+        dz(i) = 1.
+        sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+        sum_dth(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+        hw0(i) = z(i)
+      ENDDO
+c
+C 2.1 - WAPE and mean forcing computation
+C-------------------------------------------------------------
+
+C Means
+
+      DO i=1, klon
+        av_thu(i) = sum_thu(i)/hw0(i)
+        av_tu(i) = sum_tu(i)/hw0(i)
+        av_qu(i) = sum_qu(i)/hw0(i)
+        av_thvu(i) = sum_thvu(i)/hw0(i)
+        av_dth(i) = sum_dth(i)/hw0(i)
+        av_dq(i) = sum_dq(i)/hw0(i)
+        av_rho(i) = sum_rho(i)/hw0(i)
+        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+        wape2(i) = - rg*hw0(i)*(av_dth(i)
+     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+
+     $     av_dth(i)*av_dq(i) ))/av_thvu(i)
+      ENDDO
+
+C 2.2 Prognostic variable update
+C ------------------------------------------------------------
+
+C Filter out bad wakes
+c
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wape2(i) .LT. 0.) THEN
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+      ENDDO
+      ENDDO
+c
+
+      DO i=1, klon
+      IF ( wape2(i) .LT. 0.) THEN
+        wape2(i) = 0.
+        Cstar2(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = amax1(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        if(prt_level.ge.10) print*,'wape2>0'
+        Cstar2(i) = stark*sqrt(2.*wape2(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+      DO i=1, klon
+        ktopw(i) = ktop(i)
+      ENDDO
+c
+      DO i=1, klon
+      IF (ktopw(i) .gt. 0 .and. gwake(i)) then
+
+Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+ccc       heff = 600.
+C      Utilisation de la hauteur hw
+cc       heff = 0.7*hw
+       heff(i) = hw(i)
+
+       FIP(i) = 0.5*rho(i,ktopw(i))*Cstar2(i)**3*heff(i)*2*
+     $      sqrt(sigmaw(i)*wdens*3.14)
+       FIP(i) = alpk * FIP(i)
+Cjyg2
+       ELSE
+         FIP(i) = 0.
+       ENDIF
+      ENDDO
+c
+C   Limitation de sigmaw
+c
+C   sécurité : si le wake occuppe plus de 90 % de la surface de la maille,
+C              alors il disparait en se mélangeant à la partie undisturbed
+c
+      DO k = 1,klev
+       DO i=1, klon
+         IF ((sigmaw(i).GT.0.9).or.
+     $     ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN
+ccc      IF (sigmaw(i).GT.0.9) THEN
+          dtls(i,k) = 0.
+          dqls(i,k) = 0.
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+c
+      DO i=1, klon
+         IF ((sigmaw(i).GT.0.9).or.
+     $     ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0))) THEN
+ccc      IF (sigmaw(i).GT.0.9) THEN
+         wape(i) = 0.
+         hw(i) = hwmin
+         sigmaw(i) = sigmad
+         fip(i) = 0.
+        ELSE
+         wape(i) = wape2(i)
+        ENDIF
+      ENDDO
+c
+c
+      RETURN
+      END
+      Subroutine WAKE_scal (p,ph,ppi,dtime,sigd_con
+     :                ,te0,qe0,omgb
+     :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     :                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     o                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl
+     o                ,dtls,dqls
+     o                ,ktopw,omgbdth,dp_omgb,wdens
+     o                ,tu,qu
+     o                ,dtKE,dqKE
+     o                ,dtPBL,dqPBL
+     o                ,omg,dp_deltomg,spread
+     o                ,Cstar,d_deltat_gw
+     o                ,d_deltatw2,d_deltaqw2)
+
+***************************************************************
+*                                                             *
+* WAKE                                                        *
+*      retour a un Pupper fixe                                *
+*                                                             *
+* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+* modified by :   ROEHRIG Romain        01/29/2007            *
+***************************************************************
+c
+      USE dimphy
+      IMPLICIT none
+c============================================================================
+C
+C
+C   But : Decrire le comportement des poches froides apparaissant dans les
+C        grands systemes convectifs, et fournir l'energie disponible pour
+C        le declenchement de nouvelles colonnes convectives.
+C
+C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
+C                      deltaqw    : ecart d'humidite wake-undisturbed area
+C                      sigmaw     : fraction d'aire occupee par la poche.
+C
+C   Variable de sortie : 
+c
+c			 wape : WAke Potential Energy
+c                        fip  : Front Incident Power (W/m2) - ALP
+c                        gfl  : Gust Front Length per unit area (m-1)
+C                        dtls : large scale temperature tendency due to wake
+C                        dqls : large scale humidity tendency due to wake
+C                        hw   : hauteur de la poche
+C                     dp_omgb : vertical gradient of large scale omega
+C                      omgbdth: flux of Delta_Theta transported by LS omega
+C                      dtKE   : differential heating (wake - unpertubed)
+C                      dqKE   : differential moistening (wake - unpertubed)
+C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+C                 dp_deltomg  : vertical gradient of omg (s-1)
+C                     spread  : spreading term in dt_wake and dq_wake
+C                 deltatw     : updated temperature difference (T_w-T_u).
+C                 deltaqw     : updated humidity difference (q_w-q_u).
+C                 sigmaw      : updated wake fractional area.
+C                 d_deltat_gw : delta T tendency due to GW
+c
+C   Variables d'entree : 
+c
+c		         aire : aire de la maille
+c			 te0  : temperature dans l'environnement  (K)
+C                        qe0  : humidite dans l'environnement     (kg/kg)
+C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
+C                        dtdwn: source de chaleur due aux descentes (K/s)
+C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
+C			 dta  : source de chaleur due courants satures et detrain  (K/s)
+C			 dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+C                        amdwn: flux de masse total des descentes, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        amup : flux de masse total des ascendances, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        p    : pressions aux milieux des couches (Pa)
+C                        ph   : pressions aux interfaces (Pa)
+C                        ppi  : (p/p_0)**kapa (adim)
+C                        dtime: increment temporel (s)
+c
+C   Variables internes :
+c
+c			 rhow : masse volumique de la poche froide
+C                        rho  : environment density at P levels
+C                        rhoh : environment density at Ph levels
+C                        te   : environment temperature | may change within
+C                        qe   : environment humidity    | sub-time-stepping
+C                        the  : environment potential temperature
+C                        thu  : potential temperature in undisturbed area
+C                        tu   :  temperature  in undisturbed area
+C                        qu   : humidity in undisturbed area
+C                      dp_omgb: vertical gradient og LS omega
+C                      omgbw  : wake average vertical omega
+C                     dp_omgbw: vertical gradient of omgbw
+C                      omgbdq : flux of Delta_q transported by LS omega
+C                        dth  : potential temperature diff. wake-undist.
+C                        th1  : first pot. temp. for vertical advection (=thu)
+C                        th2  : second pot. temp. for vertical advection (=thw)
+C                        q1   : first humidity for vertical advection
+C                        q2   : second humidity for vertical advection
+C                     d_deltatw   : terme de redistribution pour deltatw
+C                     d_deltaqw   : terme de redistribution pour deltaqw
+C                      deltatw0   : deltatw initial
+C                      deltaqw0   : deltaqw initial
+C                      hw0    : hw initial
+C                      sigmaw0: sigmaw initial
+C                      amflux : horizontal mass flux through wake boundary
+C                      wdens  : number of wakes per unit area (3D) or per
+C                               unit length (2D)
+C                      Tgw    : 1 sur la période de onde de gravité
+c                      Cgw    : vitesse de propagation de onde de gravité
+c                      LL     : distance entre 2 poches
+
+c-------------------------------------------------------------------------
+c          Déclaration de variables
+c-------------------------------------------------------------------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "iniprint.h"
+
+c Arguments en entree
+c--------------------
+
+      REAL p(klev),ph(klev+1),ppi(klev)
+      REAL dtime
+      REAL te0(klev),qe0(klev)
+      REAL omgb(klev+1)
+      REAL dtdwn(klev), dqdwn(klev)
+      REAL wdtPBL(klev),wdqPBL(klev)
+      REAL udtPBL(klev),udqPBL(klev)
+      REAL amdwn(klev), amup(klev)
+      REAL dta(klev), dqa(klev)
+      REAL sigd_con
+
+c Sorties
+c--------
+
+      REAL deltatw(klev), deltaqw(klev), dth(klev)
+      REAL tu(klev), qu(klev)
+      REAL dtls(klev), dqls(klev)
+      REAL dtKE(klev), dqKE(klev)
+      REAL dtPBL(klev), dqPBL(klev)
+      REAL spread(klev)
+      REAL d_deltatgw(klev)
+      REAL d_deltatw2(klev), d_deltaqw2(klev)
+      REAL omgbdth(klev+1), omg(klev+1)
+      REAL dp_omgb(klev), dp_deltomg(klev)
+      REAL d_deltat_gw(klev)
+      REAL hw, sigmaw, wape, fip, gfl, Cstar
+      INTEGER ktopw
+
+c Variables internes
+c-------------------
+
+c Variables à fixer
+      REAL ALON
+      REAL coefgw
+      REAL wdens0, wdens
+      REAL stark
+      REAL alpk
+      REAL delta_t_min
+      REAL Pupper
+      INTEGER nsub
+      REAL dtimesub
+      REAL sigmad, hwmin
+
+c Variables de sauvegarde
+      REAL deltatw0(klev)
+      REAL deltaqw0(klev)
+      REAL te(klev), qe(klev)
+      REAL sigmaw0, sigmaw1
+
+c Variables pour les GW
+      REAL LL
+      REAL N2(klev)
+      REAL Cgw(klev)
+      REAL Tgw(klev)
+
+c Variables liées au calcul de hw
+      REAL ptop_provis, ptop, ptop_new
+      REAL sum_dth
+      REAL dthmin
+      REAL z, dz, hw0
+      INTEGER ktop, kupper
+
+c Autres variables internes
+      INTEGER isubstep, k
+
+      REAL sum_thu, sum_tu, sum_qu,sum_thvu
+      REAL sum_dq, sum_rho
+      REAL sum_dtdwn, sum_dqdwn
+      REAL av_thu, av_tu, av_qu, av_thvu
+      REAL av_dth, av_dq, av_rho
+      REAL av_dtdwn, av_dqdwn
+
+      REAL rho(klev), rhoh(klev+1), rhow(klev)
+      REAL rhow_moyen(klev)
+      REAL zh(klev), zhh(klev+1)
+      REAL epaisseur1(klev), epaisseur2(klev)
+
+      REAL the(klev), thu(klev)
+
+      REAL d_deltatw(klev), d_deltaqw(klev)
+
+      REAL omgbw(klev+1), omgtop
+      REAL dp_omgbw(klev)
+      REAL ztop, dztop
+      REAL alpha_up(klev)
+      
+      REAL RRe1, RRe2, RRd1, RRd2
+      REAL Th1(klev), Th2(klev), q1(klev), q2(klev)
+      REAL D_Th1(klev), D_Th2(klev), D_dth(klev)
+      REAL D_q1(klev), D_q2(klev), D_dq(klev)
+      REAL omgbdq(klev)
+
+      REAL ff, gg
+      REAL wape2, Cstar2, heff
+
+      REAL Crep(klev)
+      REAL Crep_upper, Crep_sol
+
+C-------------------------------------------------------------------------
+c         Initialisations
+c-------------------------------------------------------------------------
+
+c      print*, 'wake initialisations'
+
+c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
+c-------------------------------------------------------------------------
+
+      DATA sigmad, hwmin /.02,10./
+
+C Longueur de maille (en m)
+c-------------------------------------------------------------------------
+
+c      ALON = 3.e5
+      ALON = 1.e6
+
+
+C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+c
+c      coefgw : Coefficient pour les ondes de gravité
+c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+c       wdens : Densité de poche froide par maille
+c-------------------------------------------------------------------------
+
+      coefgw=10
+c      coefgw=1
+c      wdens0 = 1.0/(alon**2)   
+      wdens = 1.0/(alon**2)       
+      stark = 0.50
+cCRtest
+      alpk=0.1
+c      alpk = 1.0 
+c      alpk = 0.5
+c      alpk = 0.05
+      Crep_upper=0.9
+      Crep_sol=1.0
+
+
+C Minimum value for |T_wake - T_undist|. Used for wake top definition
+c-------------------------------------------------------------------------
+
+      delta_t_min = 0.2
+
+
+C 1. - Save initial values and initialize tendencies
+C --------------------------------------------------
+
+      DO k=1,klev
+	deltatw0(k) = deltatw(k)
+	deltaqw0(k)= deltaqw(k)
+	te(k) = te0(k)
+	qe(k) = qe0(k)
+	dtls(k) = 0.
+	dqls(k) = 0.
+        d_deltat_gw(k)=0.
+        d_deltatw2(k)=0.
+        d_deltaqw2(k)=0.
+      ENDDO
+c      sigmaw1=sigmaw
+c      IF (sigd_con.GT.sigmaw1) THEN
+c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+c      ENDIF
+      sigmaw = max(sigmaw,sigd_con)
+      sigmaw = max(sigmaw,sigmad)
+      sigmaw = min(sigmaw,0.99)
+      sigmaw0 = sigmaw
+c      wdens=wdens0/(10.*sigmaw)
+c      IF (sigd_con.GT.sigmaw1) THEN
+c      print*, 'sigmaw1,sigd1', sigmaw, sigd_con
+c      ENDIF
+
+C 2. - Prognostic part
+C =========================================================
+
+c      print *, 'prognostic wake computation'
+
+
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      z = 0.
+      ktop=0
+      kupper = 0
+      sum_thu = 0.
+      sum_tu = 0.
+      sum_qu = 0.
+      sum_thvu = 0.
+      sum_dth = 0.
+      sum_dq = 0.
+      sum_rho = 0.
+      sum_dtdwn = 0.
+      sum_dqdwn = 0.
+
+      av_thu = 0.
+      av_tu =0.
+      av_qu =0.
+      av_thvu = 0.
+      av_dth = 0.
+      av_dq = 0.
+      av_rho =0.
+      av_dtdwn =0.
+      av_dqdwn = 0.
+
+C Potential temperatures and humidity
+c----------------------------------------------------------
+
+      DO k =1,klev
+        rho(k) = p(k)/(rd*te(k))
+        IF(k .eq. 1) THEN
+          rhoh(k) = ph(k)/(rd*te(k))
+          zhh(k)=0
+        ELSE
+          rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1)))
+          zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1)
+        ENDIF
+        the(k) = te(k)/ppi(k)
+        thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k)
+        tu(k) = te(k) - deltatw(k)*sigmaw
+        qu(k)  =  qe(k) - deltaqw(k)*sigmaw
+        rhow(k) = p(k)/(rd*(te(k)+deltatw(k)))
+        dth(k) = deltatw(k)/ppi(k)
+        LL = (1-sqrt(sigmaw))/sqrt(wdens)       
+      ENDDO
+        
+      DO k = 1, klev-1
+        IF(k.eq.1) THEN
+          N2(k)=0
+        ELSE
+          N2(k)=max(0.,-RG**2/the(k)*rho(k)*(the(k+1)-the(k-1))
+     $           /(p(k+1)-p(k-1)))
+        ENDIF
+        ZH(k)=(zhh(k)+zhh(k+1))/2
+
+        Cgw(k)=sqrt(N2(k))*ZH(k)
+        Tgw(k)=coefgw*Cgw(k)/LL
+      ENDDO
+         
+      N2(klev)=0
+      ZH(klev)=0
+      Cgw(klev)=0
+      Tgw(klev)=0
+
+c  Calcul de la masse volumique moyenne de la colonne
+c-----------------------------------------------------------------
+
+      DO k=1,klev
+        epaisseur1(k)=0.
+        epaisseur2(k)=0.
+      ENDDO
+
+      epaisseur1(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1.
+      epaisseur2(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1.
+      rhow_moyen(1) = rhow(1)
+
+      DO k = 2, klev
+        epaisseur1(k)= -(Ph(k+1)-Ph(k))/(rho(k)*rg) +1.
+        epaisseur2(k)=epaisseur2(k-1)+epaisseur1(k)
+        rhow_moyen(k) = (rhow_moyen(k-1)*epaisseur2(k-1)+
+     $                 rhow(k)*epaisseur1(k))/epaisseur2(k)
+      ENDDO
+
+
+C Choose an integration bound well above wake top
+c-----------------------------------------------------------------
+
+c       Pupper = 50000.  ! melting level
+       Pupper = 60000.
+c       Pupper = 70000.
+
+
+C    Determine Wake top pressure (Ptop) from buoyancy integral
+C-----------------------------------------------------------------
+
+c-1/ Pressure of the level where dth becomes less than delta_t_min.
+
+      Ptop_provis=ph(1)
+      DO k= 2,klev
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_provis = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 25
+        ENDIF
+      ENDDO
+25    CONTINUE
+
+c-2/ dth integral
+
+      sum_dth = 0.
+      dthmin = -delta_t_min
+      z = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg)
+        IF (dz .le. 0) GO TO 40
+        z = z+dz
+        sum_dth = sum_dth + dth(k)*dz
+        dthmin = min(dthmin,dth(k))
+      ENDDO
+40    CONTINUE
+
+c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      hw0 = 2.*sum_dth/min(dthmin,-0.5)
+      hw0 = max(hwmin,hw0)
+
+c-4/ now, get Ptop
+
+      z = 0.
+      ptop = ph(1)
+
+      DO k = 1,klev
+        dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw0-z)
+        IF (dz .le. 0) GO TO 45
+        z = z+dz
+        Ptop = Ph(k)-rho(k)*rg*dz
+      ENDDO
+45    CONTINUE
+
+
+C-5/ Determination de ktop et kupper
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .lt. ptop) ktop=k
+        IF (ph(k+1) .lt. pupper) kupper=k
+      ENDDO
+
+c-6/ Correct ktop and ptop
+
+      Ptop_new=ptop
+      DO k= ktop,2,-1
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_new = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 225
+        ENDIF
+      ENDDO
+225   CONTINUE
+
+      ptop = ptop_new
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .lt. ptop) ktop=k
+      ENDDO
+
+c Set deltatw & deltaqw to 0 above kupper
+c-----------------------------------------------------------
+
+      DO k = kupper,klev
+        deltatw(k) = 0.
+        deltaqw(k) = 0.
+      ENDDO
+
+
+C Vertical gradient of LS omega
+C------------------------------------------------------------
+
+      DO k = 1,kupper
+        dp_omgb(k) = (omgb(k+1) - omgb(k))/(ph(k+1)-ph(k))
+      ENDDO
+
+
+C Integrals (and wake top level number)
+C -----------------------------------------------------------
+
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      z = 1.
+      dz = 1.
+      sum_thvu =  thu(1)*(1.+eps*qu(1))*dz
+      sum_dth = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg)
+        IF (dz .LE. 0) GO TO 50
+        z = z+dz
+        sum_thu = sum_thu + thu(k)*dz
+        sum_tu = sum_tu + tu(k)*dz
+        sum_qu = sum_qu + qu(k)*dz
+        sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz
+        sum_dth = sum_dth + dth(k)*dz
+        sum_dq = sum_dq + deltaqw(k)*dz
+        sum_rho = sum_rho + rhow(k)*dz
+        sum_dtdwn = sum_dtdwn + dtdwn(k)*dz
+        sum_dqdwn = sum_dqdwn + dqdwn(k)*dz
+      ENDDO
+50    CONTINUE
+
+      hw0 = z
+
+C 2.1 - WAPE and mean forcing computation
+C-------------------------------------------------------------
+
+C Means
+
+      av_thu = sum_thu/hw0
+      av_tu = sum_tu/hw0
+      av_qu = sum_qu/hw0
+      av_thvu = sum_thvu/hw0
+c      av_thve = sum_thve/hw0
+      av_dth = sum_dth/hw0
+      av_dq = sum_dq/hw0
+      av_rho = sum_rho/hw0
+      av_dtdwn = sum_dtdwn/hw0
+      av_dqdwn = sum_dqdwn/hw0
+
+      wape = - rg*hw0*(av_dth
+     $     + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu
+
+C 2.2 Prognostic variable update
+C ------------------------------------------------------------
+
+C Filter out bad wakes
+
+      IF ( wape .LT. 0.) THEN
+        if(prt_level.ge.10) print*,'wape<0'
+        wape = 0.
+        hw = hwmin
+        sigmaw = max(sigmad,sigd_con)
+        fip = 0.
+        DO k = 1,klev
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+          dth(k) = 0.
+        ENDDO
+      ELSE
+        if(prt_level.ge.10) print*,'wape>0'
+        Cstar = stark*sqrt(2.*wape)
+      ENDIF
+
+C------------------------------------------------------------------
+C    Sub-time-stepping
+C------------------------------------------------------------------
+
+c      nsub=36
+      nsub=10
+      dtimesub=dtime/nsub
+
+c------------------------------------------------------------
+      DO isubstep = 1,nsub
+c------------------------------------------------------------
+
+c        print*,'---------------','substep=',isubstep,'-------------'
+
+c  Evolution of sigmaw
+
+
+        gfl = 2.*sqrt(3.14*wdens*sigmaw)            
+
+        sigmaw =sigmaw + gfl*Cstar*dtimesub
+        sigmaw =min(sigmaw,0.99)     !!!!!!!!
+c        wdens = wdens0/(10.*sigmaw)
+c        sigmaw =max(sigmaw,sigd_con)
+c        sigmaw =max(sigmaw,sigmad)
+
+c calcul de la difference de vitesse verticale poche - zone non perturbee
+
+        z= 0.
+        dp_deltomg(1:klev)=0.
+        omg(1:klev+1)=0.
+
+        omg(1) = 0.
+        dp_deltomg(1) = -(gfl*Cstar)/(sigmaw * (1-sigmaw))
+
+        DO k=2,ktop
+          dz = -(Ph(k)-Ph(k-1))/(rho(k-1)*rg)
+          z = z+dz
+          dp_deltomg(k)= dp_deltomg(1)
+          omg(k)= dp_deltomg(1)*z
+        ENDDO
+
+        dztop=-(Ptop-Ph(ktop))/(rho(ktop)*rg)
+        ztop = z+dztop
+        omgtop=dp_deltomg(1)*ztop
+
+
+c Conversion de la vitesse verticale de m/s a Pa/s
+
+        omgtop = -rho(ktop)*rg*omgtop
+        dp_deltomg(1) = omgtop/(ptop-ph(1))
+
+        DO k = 1,ktop
+          omg(k) = - rho(k)*rg*omg(k)
+          dp_deltomg(k) = dp_deltomg(1)
+        ENDDO
+
+c   raccordement lineaire de omg de ptop a pupper
+
+      IF (kupper .GT. ktop) THEN
+        omg(kupper+1) = - Rg*amdwn(kupper+1)/sigmaw
+     $                + Rg*amup(kupper+1)/(1.-sigmaw)
+        dp_deltomg(kupper) = (omgtop-omg(kupper+1))/(Ptop-Pupper)
+        DO k=ktop+1,kupper
+          dp_deltomg(k) = dp_deltomg(kupper)
+          omg(k) = omgtop+(ph(k)-Ptop)*dp_deltomg(kupper)
+        ENDDO
+      ENDIF
+
+c   Compute wake average vertical velocity omgbw
+
+      DO k = 1,klev+1
+        omgbw(k) = omgb(k)+(1.-sigmaw)*omg(k)
+      ENDDO
+
+c  and its vertical gradient dp_omgbw
+
+      DO k = 1,klev
+        dp_omgbw(k) = (omgbw(k+1)-omgbw(k))/(ph(k+1)-ph(k))
+      ENDDO
+
+
+c  Upstream coefficients for omgb velocity
+c--    (alpha_up(k) is the coefficient of the value at level k)
+c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
+
+      DO k = 1,klev
+       alpha_up(k) = 0.
+       IF (omgb(k) .GT. 0.) alpha_up(k) = 1.
+      ENDDO
+
+c  Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+      RRe1 = 1.-sigmaw
+      RRe2 = sigmaw
+      RRd1 = -1.
+      RRd2 = 1.
+
+c Get [Th1,Th2], dth and [q1,q2]
+
+      DO k = 1,kupper+1
+        dth(k) = deltatw(k)/ppi(k)
+        Th1(k) = the(k) - sigmaw     *dth(k)   ! undisturbed area
+        Th2(k) = the(k) + (1.-sigmaw)*dth(k)   ! wake
+        q1(k) = qe(k) - sigmaw     *deltaqw(k) ! undisturbed area
+        q2(k) = qe(k) + (1.-sigmaw)*deltaqw(k) ! wake
+      ENDDO
+
+      D_Th1(1) = 0.
+      D_Th2(1) = 0.
+      D_dth(1) = 0.
+      D_q1(1) = 0.
+      D_q2(1) = 0.
+      D_dq(1) = 0.
+
+      DO k = 2,kupper+1 !   loop on interfaces
+        D_Th1(k) = Th1(k-1)-Th1(k)
+        D_Th2(k) = Th2(k-1)-Th2(k)
+        D_dth(k) = dth(k-1)-dth(k)
+        D_q1(k) = q1(k-1)-q1(k)
+        D_q2(k) = q2(k-1)-q2(k)
+        D_dq(k) = deltaqw(k-1)-deltaqw(k)
+      ENDDO
+
+      omgbdth(1) = 0.
+      omgbdq(1) = 0.
+
+      DO k = 2,kupper+1  !   loop on interfaces
+        omgbdth(k) = omgb(k)*(    dth(k-1) -     dth(k))
+        omgbdq(k)  = omgb(k)*(deltaqw(k-1) - deltaqw(k))
+      ENDDO
+
+
+c-----------------------------------------------------------------
+      DO k=1,kupper-1
+c-----------------------------------------------------------------
+c
+c   Compute redistribution (advective) term
+c
+         d_deltatw(k) =
+     $             dtimesub/(Ph(k)-Ph(k+1))*(
+     $       RRd1*omg(k  )*sigmaw     *D_Th1(k)
+     $      -RRd2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1)
+     $      -(1.-alpha_up(k))*omgbdth(k) - alpha_up(k+1)*omgbdth(k+1)
+     $                      )*ppi(k)
+c         print*,'d_deltatw=',d_deltatw(k)
+c
+         d_deltaqw(k) =
+     $             dtimesub/(Ph(k)-Ph(k+1))*(
+     $       RRd1*omg(k  )*sigmaw     *D_q1(k)
+     $      -RRd2*omg(k+1)*(1.-sigmaw)*D_q2(k+1)
+     $      -(1.-alpha_up(k))*omgbdq(k) - alpha_up(k+1)*omgbdq(k+1)
+     $                      )
+c         print*,'d_deltaqw=',d_deltaqw(k)
+c
+c   and increment large scale tendencies
+c
+         dtls(k) = dtls(k) +
+     $               dtimesub*(
+     $        ( RRe1*omg(k  )*sigmaw     *D_Th1(k)
+     $         -RRe2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) )
+     $               /(Ph(k)-Ph(k+1))
+     $         -sigmaw*(1.-sigmaw)*dth(k)*dp_deltomg(k)
+     $                      )*ppi(k)
+c         print*,'dtls=',dtls(k)
+c
+         dqls(k) = dqls(k) +
+     $               dtimesub*(
+     $        ( RRe1*omg(k  )*sigmaw     *D_q1(k)
+     $         -RRe2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) )
+     $               /(Ph(k)-Ph(k+1))
+     $         -sigmaw*(1.-sigmaw)*deltaqw(k)*dp_deltomg(k)
+     $                      )
+c         print*,'dqls=',dqls(k)
+
+c-------------------------------------------------------------------
+      ENDDO
+c------------------------------------------------------------------
+
+C   Increment state variables
+
+      DO k = 1,kupper-1
+
+c Coefficient de répartition
+
+        Crep(k)=Crep_sol*(ph(kupper)-ph(k))/(ph(kupper)-ph(1))
+        Crep(k)=Crep(k)+Crep_upper*(ph(1)-ph(k))/(p(1)-ph(kupper))
+        
+
+c Reintroduce compensating subsidence term.
+
+c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+c     .                   /(1-sigmaw)
+c
+c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+c     .                   /(1-sigmaw)
+
+        dtKE(k)=(dtdwn(k)/sigmaw - dta(k)/(1.-sigmaw))
+        dqKE(k)=(dqdwn(k)/sigmaw - dqa(k)/(1.-sigmaw))
+c        print*,'dtKE=',dtKE(k)
+c        print*,'dqKE=',dqKE(k)
+c
+        dtPBL(k)=(wdtPBL(k)/sigmaw - udtPBL(k)/(1.-sigmaw))
+        dqPBL(k)=(wdqPBL(k)/sigmaw - udqPBL(k)/(1.-sigmaw))
+c
+        spread(k) = (1.-sigmaw)*dp_deltomg(k)+gfl*Cstar/sigmaw
+c        print*,'spread=',spread(k)
+
+
+c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
+
+        d_deltat_gw(k)=d_deltat_gw(k)-Tgw(k)*deltatw(k)* dtimesub
+c        print*,'d_delta_gw=',d_deltat_gw(k)
+        ff=d_deltatw(k)/dtimesub
+
+c Sans GW
+c
+c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) 
+c
+c GW formule 1
+c
+c        deltatw(k) = deltatw(k)+dtimesub*
+c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+c
+c GW formule 2
+
+        IF (dtimesub*Tgw(k).lt.1.e-10) THEN
+          deltatw(k) = deltatw(k)+dtimesub*
+     $          (ff+dtKE(k)+dtPBL(k) 
+     $          - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+        ELSE
+           deltatw(k) = deltatw(k)+1/Tgw(k)*(1-exp(-dtimesub*Tgw(k)))*
+     $          (ff+dtKE(k)+dtPBL(k)
+     $          - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+        ENDIF
+   
+        dth(k) = deltatw(k)/ppi(k)
+
+        gg=d_deltaqw(k)/dtimesub
+
+       deltaqw(k) = deltaqw(k) +
+     $         dtimesub*(gg+ dqKE(k)+dqPBL(k) - spread(k)*deltaqw(k))
+
+       d_deltatw2(k)=d_deltatw2(k)+d_deltatw(k)
+       d_deltaqw2(k)=d_deltaqw2(k)+d_deltaqw(k)
+      ENDDO
+
+C   And update large scale variables
+
+      DO k = 1,kupper
+        te(k) = te0(k) + dtls(k)
+        qe(k) = qe0(k) + dqls(k)
+        the(k) = te(k)/ppi(k)
+      ENDDO
+
+c     Determine Ptop from buoyancy integral
+c----------------------------------------------------------------------
+
+c-1/ Pressure of the level where dth changes sign.
+
+      Ptop_provis=ph(1)
+
+      DO k= 2,klev
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_provis = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+        GO TO 65
+        ENDIF
+      ENDDO
+65    CONTINUE
+
+c-2/ dth integral
+
+      sum_dth = 0.
+      dthmin = -delta_t_min
+      z = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg)
+        IF (dz .le. 0) GO TO 70
+        z = z+dz
+        sum_dth = sum_dth + dth(k)*dz
+        dthmin = min(dthmin,dth(k))
+      ENDDO
+70    CONTINUE
+
+c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      hw = 2.*sum_dth/min(dthmin,-0.5)
+      hw = max(hwmin,hw)
+
+c-4/ now, get Ptop
+
+      ktop = 0
+      z=0.
+
+      DO k = 1,klev
+        dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw-z)
+        IF (dz .le. 0) GO TO 75
+        z = z+dz
+        Ptop = Ph(k)-rho(k)*rg*dz
+        ktop = k
+      ENDDO
+75    CONTINUE
+
+c-5/Correct ktop and ptop
+
+      Ptop_new=ptop
+
+      DO k= ktop,2,-1
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_new = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 275
+        ENDIF
+      ENDDO
+275   CONTINUE
+
+      ptop = ptop_new
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .LT. ptop) ktop=k
+      ENDDO
+
+c-6/ Set deltatw & deltaqw to 0 above kupper
+
+      DO k = kupper,klev
+        deltatw(k) = 0.
+        deltaqw(k) = 0.
+      ENDDO
+
+c------------------------------------------------------------------
+      ENDDO      ! end sub-timestep loop
+C -----------------------------------------------------------------
+
+c   Get back to tendencies per second
+
+      DO k = 1,kupper-1
+        dtls(k) = dtls(k)/dtime
+        dqls(k) = dqls(k)/dtime
+        d_deltatw2(k)=d_deltatw2(k)/dtime
+        d_deltaqw2(k)=d_deltaqw2(k)/dtime
+        d_deltat_gw(k) = d_deltat_gw(k)/dtime
+      ENDDO
+
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      z = 0.
+      sum_thu = 0.
+      sum_tu = 0.
+      sum_qu = 0.
+      sum_thvu = 0.
+      sum_dth = 0.
+      sum_dq = 0.
+      sum_rho = 0.
+      sum_dtdwn = 0.
+      sum_dqdwn = 0.
+
+      av_thu = 0.
+      av_tu =0.
+      av_qu =0.
+      av_thvu = 0.
+      av_dth = 0.
+      av_dq = 0.
+      av_rho =0.
+      av_dtdwn =0.
+      av_dqdwn = 0.
+
+C Potential temperatures and humidity
+c----------------------------------------------------------
+
+      DO k =1,klev
+        rho(k) = p(k)/(rd*te(k))
+        IF(k .eq. 1) THEN
+          rhoh(k) = ph(k)/(rd*te(k))
+          zhh(k)=0
+        ELSE
+          rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1)))
+          zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1)
+        ENDIF
+        the(k) = te(k)/ppi(k)
+        thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k)
+        tu(k) = te(k) - deltatw(k)*sigmaw
+        qu(k)  =  qe(k) - deltaqw(k)*sigmaw
+        rhow(k) = p(k)/(rd*(te(k)+deltatw(k)))
+        dth(k) = deltatw(k)/ppi(k)
+       
+      ENDDO
+
+C Integrals (and wake top level number)
+C -----------------------------------------------------------
+
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      z = 1.
+      dz = 1.
+      sum_thvu =  thu(1)*(1.+eps*qu(1))*dz
+      sum_dth = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg)
+
+        IF (dz .LE. 0) GO TO 51
+        z = z+dz
+        sum_thu = sum_thu + thu(k)*dz
+        sum_tu = sum_tu + tu(k)*dz
+        sum_qu = sum_qu + qu(k)*dz
+        sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz
+        sum_dth = sum_dth + dth(k)*dz
+        sum_dq = sum_dq + deltaqw(k)*dz
+        sum_rho = sum_rho + rhow(k)*dz
+        sum_dtdwn = sum_dtdwn + dtdwn(k)*dz
+        sum_dqdwn = sum_dqdwn + dqdwn(k)*dz
+      ENDDO
+ 51   CONTINUE
+
+      hw0 = z
+
+C 2.1 - WAPE and mean forcing computation
+C-------------------------------------------------------------
+
+C Means
+
+      av_thu = sum_thu/hw0
+      av_tu = sum_tu/hw0
+      av_qu = sum_qu/hw0
+      av_thvu = sum_thvu/hw0
+      av_dth = sum_dth/hw0
+      av_dq = sum_dq/hw0
+      av_rho = sum_rho/hw0
+      av_dtdwn = sum_dtdwn/hw0
+      av_dqdwn = sum_dqdwn/hw0
+
+      wape2 = - rg*hw0*(av_dth
+     $     + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu
+
+
+C 2.2 Prognostic variable update
+C ------------------------------------------------------------
+
+C Filter out bad wakes
+
+      IF ( wape2 .LT. 0.) THEN
+        if(prt_level.ge.10) print*,'wape2<0'
+        wape2 = 0.
+        hw = hwmin
+        sigmaw = max(sigmad,sigd_con)
+        fip = 0.
+        DO k = 1,klev
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+          dth(k) = 0.
+        ENDDO
+      ELSE
+        if(prt_level.ge.10) print*,'wape2>0'
+        Cstar2 = stark*sqrt(2.*wape2)
+
+      ENDIF
+
+      ktopw = ktop
+
+      IF (ktopw .gt. 0) then
+
+Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+ccc       heff = 600.
+C      Utilisation de la hauteur hw
+cc       heff = 0.7*hw
+       heff = hw
+
+       FIP = 0.5*rho(ktopw)*Cstar2**3*heff*2*sqrt(sigmaw*wdens*3.14)
+       FIP = alpk * FIP
+Cjyg2
+       ELSE
+         FIP = 0.
+       ENDIF
+
+
+C   Limitation de sigmaw
+c
+C   sécurité : si le wake occuppe plus de 90 % de la surface de la maille,
+C              alors il disparait en se mélangeant à la partie undisturbed
+
+      IF ((sigmaw.GT.0.9).or.
+     .     ((wape.ge.wape2).and.(wape2.le.1.0))) THEN
+c      IF (sigmaw.GT.0.9) THEN
+        DO k = 1,klev
+          dtls(k) = 0.
+          dqls(k) = 0.
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+        ENDDO
+        wape = 0.
+        hw = hwmin
+        sigmaw = sigmad
+        fip = 0.
+      ENDIF
+
+      RETURN
+      END
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/wrgradsfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/wrgradsfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/wrgradsfi.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      implicit none
+
+c   Declarations
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+
+c   arguments
+      integer if,nl
+      real fieldfi_p(klon,nl)
+      real fieldfi(klon_glo,nl)
+      real fielddyn((iim+1)*(jjm+1),llm)
+      character*10 name
+      character*10 titlevar
+
+c   local
+
+      integer lm,l,lnblnk
+
+
+
+c     print*,'Transformation pour ',name
+      call Gather(fieldfi_p,fieldfi)
+
+c$OMP MASTER      
+      if (is_mpi_root) then
+        call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn)
+        
+c     print*,'Transformation OK '
+        call wrgrads(if,nl,fielddyn,name,titlevar)
+c     print*,'Ecriture ok'
+      endif
+c$OMP END MASTER
+      
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_bilKP_ave.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_bilKP_ave.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_bilKP_ave.h	(revision 984)
@@ -0,0 +1,155 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+      itau_w = itau_phy + itap
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ue",itau_w,ue_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ve",itau_w,ve_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"uq",itau_w,uq_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vq",itau_w,vq_lay)
+c
+c Champs 3D:
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"play",itau_w,paprs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"oliq",itau_w,cldliq)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqdyn",itau_w,d_q_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtcon",itau_w,d_t_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ducon",itau_w,d_u_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvcon",itau_w,d_v_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqcon",itau_w,d_q_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlsc",itau_w,d_t_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqlsc",itau_w,d_q_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqvdf",itau_w,d_q_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtajs",itau_w,d_t_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqajs",itau_w,d_q_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dteva",itau_w,d_t_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqeva",itau_w,d_q_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtswr",itau_w,heat)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtsw0",itau_w,heat0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlwr",itau_w,cool)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlw0",itau_w,cool0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duvdf",itau_w,d_u_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvvdf",itau_w,d_v_vdf)
+c
+      IF (ok_orodr) THEN
+      IF (ok_orolf) THEN
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k)
+        d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k)
+      ENDDO
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duoli",d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvoli",itau_w,d_v_oli)
+c
+      ENDIF
+      ENDIF
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duphy",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvphy",itau_w,d_v)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), 
+cymf     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqphy",itau_w,d_qx(:,:,1))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqlphy",itau_w,d_qx(:,:,2))
+c
+C
+      if (ok_sync) then
+        call histsync(nid_bilKPave)
+      endif
+       ENDIF
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_bilKP_ins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_bilKP_ins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_bilKP_ins.h	(revision 984)
@@ -0,0 +1,179 @@
+ c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ue",itau_w,ue_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ve",itau_w,ve_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"uq",itau_w,uq_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vq",itau_w,vq_lay)
+c
+c Champs 3D:
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"play",itau_w,paprs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"oliq",itau_w,cldliq)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqdyn",itau_w,d_q_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtcon",itau_w,d_t_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ducon",itau_w,d_u_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvcon",itau_w,d_v_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqcon",itau_w,d_q_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlsc",itau_w,d_t_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqlsc",itau_w,d_q_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqvdf",itau_w,d_q_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtajs",itau_w,d_t_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqajs",itau_w,d_q_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dteva",itau_w,d_t_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqeva",itau_w,d_q_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtswr",itau_w,heat)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtsw0",itau_w,heat0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlwr",itau_w,cool)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlw0",itau_w,cool0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duvdf",itau_w,d_u_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvvdf",itau_w,d_v_vdf)
+c
+      IF (ok_orodr) THEN
+      IF (ok_orolf) THEN
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k)
+        d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k)
+      ENDDO
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duoli",itau_w,d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvoli",itau_w,d_v_oli)
+c
+      ENDIF
+      ENDIF
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duphy",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvphy",itau_w,d_v)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqphy",itau_w,d_qx(:,:,1))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqlphy",itau_w,d_qx(:,:,2))
+c
+cIM 280405 BEG
+c
+c Champs 2D:
+c
+c   Ecriture de champs dynamiques sur des niveaux de pression
+c     DO k=1, nlevSTD
+      DO k=1, 12
+c
+       IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+       IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+       IF(bb2.EQ."850") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_bilKPins,"u"//bb2,itau_w,usumSTD(:,k,1))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_bilKPins,"v"//bb2,itau_w,vsumSTD(:,k,1))
+c
+       ENDIF !(bb2.EQ."850")
+c
+       ENDDO !k=1, 12
+c
+cIM 280405 END
+C
+      if (ok_sync) then
+        call histsync(nid_bilKPins)
+      endif
+       ENDIF
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_field_phy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_field_phy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_field_phy.F90	(revision 984)
@@ -0,0 +1,36 @@
+!
+! $Header$
+!
+MODULE write_field_phy
+
+  CONTAINS 
+ 
+    SUBROUTINE WriteField_phy(name,Field,ll)
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE mod_grid_phy_lmdz
+    USE Write_Field
+    
+    IMPLICIT NONE
+    include 'dimensions.h'
+    include 'paramet.h'
+
+    character(len=*)   :: name
+    INTEGER :: ll
+    real, dimension(klon_omp,ll) :: Field
+    real,save,allocatable :: Field_tmp(:,:)
+    real, dimension(klon_glo,ll):: New_Field
+    real, dimension(iim,jjp1,ll):: Field_2d
+
+    CALL Gather(Field,New_Field)
+!$OMP MASTER
+    IF (is_mpi_root) THEN	
+      CALL Grid1Dto2D_glo(New_Field,Field_2D)
+      CALL WriteField(name,Field_2d)
+    ENDIF
+!$OMP END MASTER
+
+  
+   END SUBROUTINE WriteField_phy
+ 
+ END MODULE write_field_phy
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histISCCP.h	(revision 984)
@@ -0,0 +1,208 @@
+!
+! $Header$
+!
+      IF (ok_isccp) THEN
+c
+       ndex2d = 0
+       ndex3d = 0
+c
+       itau_w = itau_phy + itap
+c
+       IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+        DO n=1, napisccp
+c
+        DO k=1,kmaxm1
+         zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1,n)*100.
+cym         CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d,
+cym     .                    zx_tmp_3d)
+c
+cIM: champ 3d : (lon,lat,pres) pour un tau fixe
+c
+      CALL histwrite_phy(nid_isccp,"cldISCCP_"//taulev(k)//verticaxe(n),
+     .                  itau_w,zx_tmp_fi3d)
+        ENDDO !k
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),itau_w,
+     .                 nbsunlit(1,:,n))
+c
+        ENDDO ! n=1, napisccp
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+        DO n=1, napisccp
+c        print*,'n=',n,' write_ISCCP avant fq_isccp'
+         DO k=1, kmaxm1
+          DO l=1, lmaxm1
+c
+         IF(top_height.LE.2) THEN
+          DO i=1, klon
+           IF(nbsunlit(1,i,n).NE.0.) THEN
+            fq_is_true(i,k,l,n)=
+     $      fq_isccp(i,k,l,n)*100./nbsunlit(1,i,n)
+           ELSE
+            fq_is_true(i,k,l,n)=0
+           ENDIF
+          ENDDO 
+         ELSE IF(top_height.EQ.3) THEN 
+          DO i=1, klon
+           fq_is_true(i,k,l,n) = fq_isccp(i,k,l,n)*100.
+          ENDDO
+         ENDIF
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,fq_is_true,
+cym     .                    zx_tmp_2d)
+c
+cIM: champ 2d : (lon,lat) pour un tau et une pc fixes
+c
+         CALL histwrite_phy(nid_isccp,pclev(l)//taulev(k)//verticaxe(n),
+     .                  itau_w,fq_is_true(:,k,l,n))
+         ENDDO !l
+        ENDDO !k
+c
+c       print*,'n=',n,' write_ISCCP avant nbsunlit'
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),
+     .                 itau_w,nbsunlit(1,:,n))
+c
+        zx_tmp_fi2d(1:klon)=float(seed(1:klon,n))
+c
+c       print*,'n=',n,' write_ISCCP avant seed'
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"seed"//verticaxe(n),
+     .                 itau_w,zx_tmp_fi2d)
+c
+c 9types de nuages ISCCP-D2
+c fq_isccp(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +
+     $  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +
+     $  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+        ENDDO
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cirr",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +
+     $   fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +
+     $   fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cist",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +
+     $   fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +
+     $   fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"deep",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +
+     $  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alcu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +
+     $   fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alst",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +
+     $   fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nist",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +
+     $  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cumu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +
+     $   fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stcu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +
+     $   fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stra",itau_w,zx_tmp_fi2d)
+c
+c 3_tau_nuages x 3_levels
+c fq_is_true(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         cld_fi3d(i,1)= 
+     $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +
+     $  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +
+     $  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+	 cld_fi3d(i,2)=
+     $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +
+     $  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+         cld_fi3d(i,3)=
+     $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +
+     $  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO   
+cym        CALL gr_fi_ecrit(lmax3,klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thin",itau_w,cld_fi3d)
+c
+        DO i=1, klon
+	 cld_fi3d(i,1)=
+     $   (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +
+     $    fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +
+     $    fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+	 cld_fi3d(i,2)=
+     $   (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +
+     $    fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+	 cld_fi3d(i,3)=
+     $   (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +
+     $    fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+	ENDDO   
+cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"mid",itau_w,cld_fi3d)
+c
+        DO i=1, klon
+	 cld_fi3d(i,1)=
+     $   (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +
+     $    fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +
+     $    fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+         cld_fi3d(i,2)=
+     $   (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +
+     $    fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+	 cld_fi3d(i,3)=
+     $   (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +
+     $    fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO   
+cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thick",itau_w,cld_fi3d)
+c
+        ENDDO ! n=1, napisccp
+c
+       ENDIF
+c
+       if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_isccp)
+c$OMP END MASTER       
+       endif
+
+      ENDIF !ok_isccp
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histREGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histREGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histREGDYN.h	(revision 984)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      if (ok_regdyn) then
+      
+      if (is_sequential) then
+
+
+      ndex3d = 0
+      itau_w = itau_phy + itap
+c
+       CALL histwrite(nid_regdyn,"hw1",itau_w,histoW(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh1",itau_w,nhistoW(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht1",itau_w,nhistoWt(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw2",itau_w,histoW(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh2",itau_w,nhistoW(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht2",itau_w,nhistoWt(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw3",itau_w,histoW(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh3",itau_w,nhistoW(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht3",itau_w,nhistoWt(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw4",itau_w,histoW(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh4",itau_w,nhistoW(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht4",itau_w,nhistoWt(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw5",itau_w,histoW(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh5",itau_w,nhistoW(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht5",itau_w,nhistoWt(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+
+      if (ok_sync) then
+        call histsync(nid_regdyn)
+      endif
+
+      endif ! is_sequential
+
+      endif
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histday.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histday.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histday.h	(revision 984)
@@ -0,0 +1,636 @@
+c
+c $Header$
+c
+      if (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         itau_w = itau_phy + itap
+
+c  temperature tendency due to moist convective processes
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=d_t_con(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+      IF(lev_histday.GE.1) THEN
+c
+       CALL histwrite_phy(nid_day,"phis",itau_w,pphis)
+ 
+c
+       CALL histwrite_phy(nid_day,"aire",itau_w,airephy)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"contfracATM",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"contfracOR",itau_w,
+     &                   pctsrf_new(:,is_ter))
+c
+
+      CALL histwrite_phy(nid_day,"dthmin",itau_w,dthmin)
+      CALL histwrite_phy(nid_day,"weakinv",itau_w,weak_inversion)
+
+cIM: 101003 : K/30min ==> K/s
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tsol",itau_w,zxtsol)
+C
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m",itau_w,zt2m)
+c
+c   En attendant un eventuel debugage.
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m_min",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m_max",itau_w,zt2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_lsc,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowl",itau_w,snow_lsc)
+c
+      IF(1.EQ.0) THEN
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_con,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowc",itau_w,snow_con)
+      ENDIF
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"flat",itau_w,zxfluxlat)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sicf",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10m",itau_w,zv10m)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)     
+      CALL histwrite_phy(nid_day,"wind10m",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"wind10max",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+         zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowf",itau_w,snow_fall)
+c
+cIM: 140404   CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite(nid_day,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldt",itau_w,cldt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldq",itau_w,cldq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"prw",itau_w,prw)
+
+c   Ecriture de champs dynamiques sur des niveaux de pression
+c     DO k=1, nlevENS
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"u"//bb2,itau_w,usumSTD(:,k,1))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"v"//bb2,itau_w,vsumSTD(:,k,1))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+c w500
+c
+      IF(bb2.EQ."500") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"w"//bb2,itau_w,wsumSTD(:,k,1))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"phi"//bb2,itau_w,phisumSTD(:,k,1))
+
+      ENDIF !(bb2.EQ."500") THEN
+c
+      ENDDO !nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cape_max",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"solldown",itau_w,sollwdown)
+c
+      DO i=1, klon
+        zx_tmp_fi2d(i)=-1*sens(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sens",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn(1 : klon, 1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"lmt_bils",itau_w, zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"slab_bils",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"siceh",itau_w,seaice/1000.)
+c
+      ENDIF !(OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      ENDIF !lev_histday.GE.1
+c
+      IF(lev_histday.GE.2) THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"bils",itau_w, bils)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fder",itau_w,fder)
+c
+      ENDIF !lev_histday.GE.2
+c
+      IF(lev_histday.GE.3) THEN
+c=================================================================
+c   ECRITURE DES CHAMPS 3D
+c=================================================================
+
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"pres",itau_w,pplay)
+c
+      CALL histwrite_phy(nid_day,"rhum",itau_w,zx_rh)
+
+cFin Wake parameters 2D     
+c Wake parameters 3D
+c
+	  print*,'SSS test2'
+c  if (1.eq.0) then
+
+c
+      ENDIF !lev_histday.GE.3
+c=================================================================
+c   FIN ECRITURE DES CHAMPS 3D
+c=================================================================
+      IF(lev_histday.ge.4) THEN
+c=================================================================
+c
+c   ECRITURE DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+      zx_tmp_fi2d(1 : klon) = swup( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c 
+      zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c 
+      zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM AMMA-MIP
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"LWdnSFC",itau_w,sollwdown)
+c
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+cIM   IF (iflag_con.GE.3) THEN
+        if (ok_ISCCP) then
+cIM ema_pct= 0.     CALL gr_fi_ecrit(1, klon,iim,jjmp1, ema_pct,zx_tmp_2d)
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, meanptop(:,1),zx_tmp_2d)
+          CALL histwrite_phy(nid_day,"ptop",itau_w,meanptop(:,1))
+	ENDIF
+cIM   ENDIF
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"toce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tsic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter_min",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter_max",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2msic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10msic",itau_w,zx_tmp_fi2d)
+C
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10msic",itau_w,zx_tmp_fi2d)
+C
+      DO nsrf = 1, nbsrf
+C
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"pourc_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"fract_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"tsol_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"sens_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C  
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"lat_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"taux_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"tauy_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"albe_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"rugs_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C 
+! FH Sorties specifiques pour Mellor et Yamada
+      if (iflag_pbl>1 .and. lev_histday.gt.10 ) then
+
+        CALL histwrite_phy(nid_day,"tke_"//clnsurf(nsrf),itau_w,
+     $      pbl_tke(:,1:klev,nsrf))
+
+        CALL histwrite_phy(nid_day,"tke_max_"//clnsurf(nsrf),itau_w,
+     $      pbl_tke(:,1:klev,nsrf))
+	endif
+
+      END DO  
+c=================================================================
+c   FIN ECRITURE DES CHAMPS SUR LES SOUS SURFACES
+c=================================================================
+      ENDIF !lev_histday.GE.4
+c
+      IF(lev_histday.GE.5) THEN !lev_histday.GE.5
+c
+c rajout sorties F. Aires
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"topl0",itau_w,toplw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"soll0",itau_w, sollw0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"rneb",itau_w,cldfra)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"iwcon",itau_w,fiwc)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, meantaucld,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"meantaucld",itau_w,meantaucld)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldtau,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"cldtau",itau_w,cldtau)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldemi,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"cldemi",itau_w,cldemi)
+c
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=
+     s   (d_q_vdf(1:klon,1:klev)+d_q_ajs(1:klon,1:klev))/pdtphys
+      CALL histwrite_phy(nid_day,"dqpbl",itau_w,zx_tmp_fi3d)
+
+      CALL histwrite_phy(nid_day,"dtwak",itau_w,dt_wake)
+
+	  CALL histwrite_phy(nid_day,"cape",itau_w,cape)
+c
+      CALL histwrite_phy(nid_day,"wh",itau_w,wake_h)
+c
+      CALL histwrite_phy(nid_day,"ws",itau_w,wake_s)
+c
+      CALL histwrite_phy(nid_day,"cin",itau_w,cin)
+
+      CALL histwrite_phy(nid_day,"wale",itau_w,ale_wake)
+c
+      CALL histwrite_phy(nid_day,"walp",itau_w,alp_wake)
+c
+      CALL histwrite_phy(nid_day,"blale",itau_w,Ale_bl)
+c
+      CALL histwrite_phy(nid_day,"blalp",itau_w,Alp_bl)
+
+      CALL histwrite_phy(nid_day,"wdt1",itau_w,wake_deltat(:,1))
+c
+      CALL histwrite_phy(nid_day,"wdq1",itau_w,wake_deltaq(:,1))
+c
+
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"dtcon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"dqcon",itau_w,zx_tmp_fi3d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, zx_tmp_2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"rh2m",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, qsat2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"qsat2m",itau_w,qsat2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, tpot,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tpot",itau_w,tpot)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, tpote,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tpote",itau_w,tpote)
+c
+      ENDIF !lev_histday.GE.5
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_day)
+c$OMP END MASTER
+      endif
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histday_seri.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histday_seri.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histday_seri.h	(revision 984)
@@ -0,0 +1,242 @@
+c
+c $Header$
+c
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+c
+      ndex2d = 0
+      itau_w = itau_phy + itap
+c
+c Champs 2D:
+c
+      pi = ACOS(-1.)
+      pir = 4.0*ATAN(1.0) / 180.0
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=(topsw(i)-toplw(i))
+      ENDDO
+c
+      ok_msk=.FALSE.
+      msk(1:klon)=pctsrf(1:klon,is_ter)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bilTOA",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, bils, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bils",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO k=1, klev
+      DO i=1, klon
+cIM 080904    zx_tmp_fi3d(i,k)=u(i,k)**2+v(i,k)**2
+       zx_tmp_fi3d(i,k)=(u(i,k)**2+v(i,k)**2)/2.
+      ENDDO
+      ENDDO
+c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, 
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"ecin",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+cIM 151004 BEG
+      IF(1.EQ.0) THEN
+c
+      DO k=1, klev
+      DO i=1, klon
+       zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i))
+      ENDDO
+      ENDDO
+c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, 
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+c friction torque
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i))
+      ENDDO
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+c mountain torque
+c
+cIM 190504 BEG
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_dyn(klev+1,klon,iim+1,jjm+1,paprs,padyn)
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,rlat,rlatdyn)
+      mountor=0.
+      airetot=0.
+      DO j = 1, jjmp1
+       DO i = 1, iim+1
+        ij=i+(iim+1)*(j-1)
+        zx_tmp(ij)=0.
+        DO k = 1, klev
+         zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)*
+     $              (padyn(i,j,k+1)-padyn(i,j,k))/RG
+         airetot=airetot+airedyn(i,j)
+        ENDDO
+cIM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA*
+        mountor=mountor+zx_tmp(ij)*RA*
+     $           cos(pir* rlatdyn(i,j))
+       ENDDO
+      ENDDO
+cIM 151004 BEG
+      IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev
+cIM 151004 END
+cIM 190504      mountor=mountor/(airetot*airetot)
+      mountor=mountor/airetot
+c
+cIM 190504 END
+      zx_tmp_2d(1:iim,1:jjmp1)=mountor
+      CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      ENDIF !(1.EQ.0) THEN
+c
+c
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      airetot=0.
+c     DO j = 1, jjmp1
+c      DO i = 1, iim+1
+c       ij=i+(iim+1)*(j-1)
+c       DO k = 1, klev
+c        airetot=airetot+airedyn(i,j)
+c        airetot=airetot+airedyn(i,j)
+c       ENDDO !k
+c      ENDDO !i
+c     ENDDO !j
+c
+      DO i=1, klon
+       airetot=airetot+airephy(i)
+      ENDDO
+c     IF(itap.EQ.1) PRINT*,'airetotphy=',airetot
+c
+      airetot=0.
+      DO j=1, jjmp1
+       DO i=1, iim
+        airetot=airetot+zx_tmp_2d(i,j)
+       ENDDO
+      ENDDO
+c
+c     IF(itap.EQ.1) PRINT*,'airetotij=',airetot,
+c    $ '4piR2',4.*pi*RA*RA
+c
+      zx_tmp_fi2d(1:klon)=aam/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1:klon)=torsfc/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"torsfc",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+cIM 151004 END
+c
+      CALL moyglo_pondmass(klon, klev, t_seri,
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tamv",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, paprs(:,1), airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"psol",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, evap, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"evap",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c     DO i=1, klon
+c      zx_tmp_fi2d(i)=SnowFrac(i,is_ter)
+c     ENDDO
+c
+c     ok_msk=.TRUE.
+c     msk(1:klon)=pctsrf_new(1:klon,is_ter)
+c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+c    .                     ok_msk, msk, moyglo)
+c     zx_tmp_fi2d(1:klon)=moyglo
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+c     CALL histwrite(nid_day_seri,"SnowFrac",
+c    .               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+c     DO i=1, klon
+cIM 080904    zx_tmp_fi2d(i)=zsnow_mass(i)/330.*rowl
+c      zx_tmp_fi2d(i)=zsnow_mass(i)
+c     ENDDO
+c
+cIM 140904   ok_msk=.FALSE.
+c     ok_msk=.TRUE.
+c     msk(1:klon)=pctsrf(1:klon,is_ter)
+c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+c    .     ok_msk, msk, moyglo)
+c     zx_tmp_fi2d(1:klon)=moyglo
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+c     CALL histwrite(nid_day_seri,"snow_depth",itau_w,
+c    .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=ftsol(i,is_oce)
+      ENDDO
+c
+      ok_msk=.TRUE.
+      msk(1:klon)=pctsrf(1:klon,is_oce)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tsol_"//clnsurf(is_oce),
+     $               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_day_seri)
+      endif
+c
+      ENDIF !fin test sur type_run.EQ."AMIP"
+      
+      ENDIF  ! mono_cpu
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histhf.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histhf.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histhf.h	(revision 984)
@@ -0,0 +1,356 @@
+!
+! $Header$
+!
+      if (ok_hf) then
+
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, paire_ter, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"aireTER",itau_w,paire_ter)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"contfracATM",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"contfracOR",itau_w,
+     .                   pctsrf_new(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t2m",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q2m",itau_w,zq2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"precip",itau_w,zx_tmp_fi2d)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"slp",itau_w,slp)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v10m",itau_w,zv10m)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."500") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w, philevSTD(:,k))
+      ENDIF !bb2.EQ."500"
+      ENDDO
+c
+      ENDIF !lev_histhf.GE.1
+c
+      IF(lev_histhf.GE.2) THEN
+c
+cIM 140904 BEG
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = cldt(i)*100.
+      ENDDO
+cIM 140904 END
+cIM 140904   CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cldt",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"SWnetOR",itau_w, zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol1(1:klon))
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"SWdownOR",itau_w, zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWdownOR",itau_w,sollwdown) 
+c
+c
+      ENDIF !lev_histhf.GE.2
+c
+      IF(lev_histhf.GE.3) THEN
+c
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t"//bb2,itau_w, tlevSTD(:,k))
+c
+      IF(bb2.NE."500") THEN !bb2.NE."500"
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,philevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w,philevSTD(:,k))
+      ENDIF !bb2.NE."500"
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q"//bb2,itau_w, qlevSTD(:,k))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u"//bb2,itau_w,ulevSTD(:,k))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v"//bb2,itau_w, vlevSTD(:,k))
+c
+      ENDIF !bb2.EQ."850".OR.bb2.EQ."700"
+      ENDDO !nlevENS
+c
+      IF(1.EQ.0) THEN
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cdrh",itau_w,cdragh)
+      ENDIF !(1.EQ.0) THEN
+c
+      ENDIF !lev_histhf.GE.3
+c
+      IF(lev_histhf.GE.4) THEN 
+c
+#undef histhf3d
+#define histhf3d
+#ifdef histhf3d
+#include "write_histhf3d.h"
+#endif
+c
+      ENDIF !lev_histhf.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+      DO k=1, nlevSTD
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+        IF(bb2.EQ."850".or.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"u"//bb2,itau_w,ulevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"v"//bb2,itau_w,vlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."850".or.bb2.EQ."200"
+c
+      ENDDO !nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"topl",itau_w,toplw)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"slp",itau_w,slp)
+c
+cIM 280504 BEG
+      ENDIF !(lev_histhf.GE.1) THEN
+c
+      IF(lev_histhf.GE.2) THEN
+c
+       DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+        IF(bb2.EQ."850".or.bb2.EQ."500") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"t"//bb2,itau_w,tlevSTD(:,k))
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"q"//bb2,itau_w, qlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."850".or.bb2.EQ."500"
+c
+        IF(bb2.EQ."500") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w, philevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, wlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"w"//bb2,itau_w, wlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."500"
+c
+        IF(bb3.EQ."50") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"t"//bb3,itau_w, tlevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"u"//bb3,itau_w, ulevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"v"//bb3,itau_w, vlevSTD(:,k))
+c
+        ENDIF !bb3.EQ."50"
+c
+       ENDDO !k=1, nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v10m",itau_w,zv10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t2m",itau_w, zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q2m",itau_w,zq2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"psol",itau_w,zx_tmp_fi2d)
+c
+cIM 140904 BEG
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = cldt(i)*100.
+      ENDDO
+cIM 140904 END
+cIM 140904   CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cldt",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = zxfluxu(1 : klon, 1)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"taux",itau_w,zx_tmp_fi2d)
+C
+      zx_tmp_fi2d(1 : klon) = zxfluxv(1 : klon, 1)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"tauy",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"prw",itau_w,prw)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"flat",itau_w,zxfluxlat)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_hf,"snow_mass",itau_w,zsnow_mass)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWdnSFC",itau_w,sollwdown)
+c
+cIM 090904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWupSFC",itau_w,zx_tmp_fi2d)                    
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+      IF (is_sequential) THEN
+cym      CALL gr_fi_ecrit(nbteta,klon,iim,jjmp1,PVteta,zx_tmp_3dte)
+      DO k=1, nbteta
+       zx_tmp_fi2d(1:klon) = PVteta(1:klon,k)
+       CALL histwrite_phy(nid_hf,"PV"//ctetaSTD(k),
+     .      itau_w,zx_tmp_fi2d)
+      ENDDO !k=1, nbteta
+      ENDIF
+c
+c
+c planetary boundary layer height
+c
+c     ENDIF !1.EQ.0
+c
+      ENDIF !(lev_histhf.GE.2) THEN
+cIM 280504 END
+c
+      ENDIF !type_run
+c
+      IF (ok_sync) THEN
+c$OMP MASTER
+        call histsync(nid_hf)
+c$OMP END MASTER
+      ENDIF
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histhf3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histhf3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histhf3d.h	(revision 984)
@@ -0,0 +1,28 @@
+
+c
+c $Header$
+c
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"vitv",itau_w,v_seri)
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_hf3d)
+c$OMP END MASTER      
+      endif
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histins.h	(revision 984)
@@ -0,0 +1,234 @@
+!
+! $Header$
+!
+      IF (ok_instan) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+      itau_w = itau_phy + itap
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"phis",itau_w,pphis)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"aire",itau_w,airephy)
+
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"precip",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)    
+      CALL histwrite_phy(nid_ins,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"pluc",itau_w,zx_tmp_fi2d)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"tsol",itau_w,zxtsol)
+cccIM
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"t2m",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"v10m",itau_w,zv10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"snow",itau_w,snow_fall)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"solldown",itau_w,sollwdown)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"fder",itau_w,fder)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfo",itau_w,d_ts(:,is_oce))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdft",itau_w,d_ts(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfg",itau_w, d_ts(:,is_lic))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfi",itau_w,d_ts(:,is_sic))
+
+      DO nsrf = 1, nbsrf
+CXXX
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"pourc_"//clnsurf(nsrf),itau_w,
+     $                zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"tauy_"//clnsurf(nsrf),itau_w,
+     $     zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C 
+      END DO  
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol1,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"albs",itau_w,albsol1)
+      
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol2,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"albslw",itau_w,albsol2)
+
+c
+cIM: 140404   CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_ins,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"rugs",itau_w,zxrugs)
+c
+cIM cf. AM 081204 BEG
+c
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"dqvdf",itau_w,d_q_vdf)
+
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_ins)
+c$OMP END MASTER
+      endif
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histmth.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histmth.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histmth.h	(revision 984)
@@ -0,0 +1,1927 @@
+c
+c $Header$
+c
+      IF (ok_mensuel) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+
+         itau_w = itau_phy + itap
+
+c  temperature tendency due to moist convective processes
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=d_t_con(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+c Champs 2D:
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phis",itau_w,pphis)
+C
+cIM 310804   CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"aire",itau_w,airephy)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m",itau_w,zt2m)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"t2m_min",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"t2m_max",itau_w,zt2m)
+c
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"tsoil",itau_w,zx_tmp_2d,
+c    .               iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sicf",itau_w,zx_tmp_fi2d)
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"temp",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+c ENSEMBLES END
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"v10m",itau_w,zv10m)
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"psol",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"qsurf",itau_w,zxqsurf)
+c
+      if (.not. ok_veget) then
+cym          CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d)
+          CALL histwrite_phy(nid_mth,"qsol",itau_w,qsol)
+      endif
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"ndayrain",itau_w,nday_rain)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"snow",itau_w,snow_fall)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl0",itau_w,toplw0)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+c
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200",itau_w,SWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200clr",itau_w,SWup200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200",itau_w,SWdn200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200clr",itau_w,SWdn200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200",itau_w,LWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200clr",itau_w,LWup200clr)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200clr",itau_w,zx_tmp_fi2d)
+c
+c200 END 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll0",itau_w,sollw0)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       sollwdownclr(i)=-1.*lwdn0(i,1)
+      ENDDO !i=1, klon
+
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)-sollwdownclr(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFC",itau_w,sollwdown)
+c
+c     DO i=1, klon
+cIM 080904     sollwdownclr(i)=lwdn0(i,1)
+c      sollwdownclr(i)=-1.*lwdn0(i,1)
+c     ENDDO !i=1, klon
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFCclr",itau_w,sollwdownclr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fder",itau_w,fder)
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"ffonte",itau_w,zxffonte)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqcalving",itau_w,zxfqcalving)
+
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqfonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqfonte",itau_w,zxfqfonte)
+
+       DO nsrf = 1, nbsrf
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDDO
+c
+      DO nsrf = 1, nbsrf
+CYYY
+       IF(nsrf.GE.2) THEN
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+       ENDIF !nsrf.GT.2
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       IF(1.EQ.0) THEN
+C
+        zx_tmp_fi2d(1:klon) = fevap(1:klon,nsrf)*pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"evapour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1:klon) = (rain_fall(1:klon) + snow_fall(1:klon))
+     $                        *pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"prepour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       ENDIF !(1.EQ.0) THEN
+C
+      END DO  
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldt",itau_w,cldt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldq",itau_w,cldq)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ue",itau_w,ue)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ve",itau_w,ve)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"uq",itau_w,uq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"vq",itau_w,vq)
+cKE43
+      IF (iflag_con.GE.3) THEN ! sb
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cape",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pbase",itau_w,pbase)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ptop",itau_w,ema_pct)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fbase",itau_w,ema_cbmf)
+c
+c34EK
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"prw",itau_w,prw)
+c
+      ENDIF !iflag_con.GE.3
+c
+c
+cIM cf. AM 081204 BEG
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c  Champs interpolles sur des niveaux de pression
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"u"//bb2,itau_w,usumSTD(:,k,2))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"v"//bb2,itau_w,vsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"w"//bb2,itau_w,wsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phi"//bb2,itau_w,phisumSTD(:,k,2))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+      ENDDO !nlevSTD
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     .     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ 
+     .                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     .                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t_oce_sic",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lmt_bils",itau_w,zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slab_bils",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"siceh",itau_w, seaice/1000.)
+c
+      ENDIF !OCEAN.EQ.force/slab
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+C
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"iwcon",itau_w,fiwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"temp",itau_w,t_seri)
+c
+c#ifdef histmthNMC
+c#include "write_histmthNMC.h"
+c#endif
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ovap",itau_w,qx(:,:,ivap))
+c
+c     zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/
+c    .                         (1-qx(1:klon,1:klev,ivap))
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+c     CALL histwrite(nid_mth,"wvap",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rneb",itau_w,cldfra)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rhum",itau_w,zx_rh)
+
+      DO k=1, klev
+       DO i=1, klon
+cIM 151004      zx_tmp_fi3d(i,k)=MAX(wo(i,k),1.0e-12)*RG/46.6968
+c    $                    /(paprs(i,k)-paprs(i,k+1))
+c    $                    *(paprs(i,1)/101325.0)
+c        zx_tmp2_fi3d(i,k)=MAX(wo(i,k)*1.0e+6,1.0e-6)*RG/46.6968
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp2_fi3d,zx_tmp_3d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ozone",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap), 
+cym     .                 zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqphy",itau_w, d_qx(:,:,ivap))
+cIM 22.03.04 END
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+       DO nsrf=1, nbsrf
+c
+        zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ages_"//clnsurf(nsrf),itau_w
+     $    ,zx_tmp_fi2d)
+c
+      ENDDO !nsrf=1, nbsrf
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albs",itau_w,albsol1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albslw",itau_w,albsol2)
+c
+      ENDIF !lev_histmth.GE.3
+c
+c
+      IF(lev_histmth.GE.4) THEN
+c
+c  FH Sorties pour la couche limite
+      CALL histwrite_phy(nid_mth,"kz",itau_w,ycoefh)
+      CALL histwrite_phy(nid_mth,"kz_max",itau_w,ycoefh)
+
+      if(iflag_pbl>1) then
+      zx_tmp_fi3d=0.
+      do nsrf=1,nbsrf
+         do k=1,klev
+          zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k)
+     ,    +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+         enddo
+      enddo
+      CALL histwrite_phy(nid_mth,"tke",itau_w,zx_tmp_fi3d)
+      CALL histwrite_phy(nid_mth,"tke_max",itau_w,zx_tmp_fi3d)
+      endif
+
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"clwcon",itau_w,clwcon0)
+
+      IF (iflag_con.GE.3) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"Ma",itau_w,Ma)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"upwd",itau_w,upwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd",itau_w,dnwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd0",itau_w,dnwd0)
+c
+      ENDIF !iflag_con.GE.3
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdyn",itau_w,d_q_dyn)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtcon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqcon",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlsc",itau_w,zx_tmp_fi3d)
+cIM: 071003
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     .                             d_t_eva(1:klon,1:klev))/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlschr",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqlsc",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqvdf",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dteva",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqeva",itau_w,zx_tmp_fi3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ptconv",itau_w,zpt_conv)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ratqs",itau_w,ratqs)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtajs",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqajs",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtthe",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqthe",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY 
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtswr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlwr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : deja en K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtec",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvvdf",itau_w,zx_tmp_fi3d)
+c
+      IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoro",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoro",itau_w,zx_tmp_fi3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dulif",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvlif",itau_w,zx_tmp_fi3d)
+      ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      CALL histwrite_phy(nid_mth,"tau",itau_w,cldtau)
+      CALL histwrite_phy(nid_mth,"CCM1",itau_w,ccm(:,:,1))
+      CALL histwrite_phy(nid_mth,"CCM2",itau_w,ccm(:,:,2))
+      CALL histwrite_phy(nid_mth,"taupi",itau_w,cldtaupi)
+      CALL histwrite_phy(nid_mth,"cldemi",itau_w,cldemi)
+      CALL histwrite_phy(nid_mth,"SWTOAAS_ZERO",itau_w,topsw_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AER",itau_w,topsw_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_NAT",itau_w,topsw_inca(:,3))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AD",itau_w,topswad_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AI",itau_w,topswai_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_ZERO",itau_w,topsw0_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AER",itau_w,topsw0_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AD",itau_w,topswad0_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_NAT",itau_w,topsw0_inca(:,3))
+#endif
+#ifndef INCA
+      IF (nqmax.GE.3) THEN
+      DO iq=3,nqmax
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq), zx_tmp_3d)
+         CALL histwrite_phy(nid_mth,tnom(iq),itau_w,qx(:,:,iq))
+      ENDDO
+      ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+c Champs 2D:
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis/RG,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phis",itau_w,pphis/RG)
+C
+cIM 310804   CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"aire",itau_w,airephy)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_ter),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_ter),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_lic)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_lic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_lic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_sic)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_sic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_sic),itau_w,
+     $      zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"flat",itau_w,zxfluxlat)
+c
+      zx_tmp_fi2d(1 : klon) = topsw(1:klon)-toplw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bilTOA",itau_w,zx_tmp_fi2d)
+c
+c     IF(itap.EQ.ecrit_mth) THEN
+c       DO i=1, klon
+c         IF(nday_clr(i).GT.0.) THEN
+c          tops01(i)=tops01(i)/nday_clr(i)
+c         ELSE
+c          tops01(i)=1.e+20
+c         ENDIF
+c       ENDDO
+c       CALL gr_fi_ecrit(1, klon,iim,jjmp1, tops01,zx_tmp_2d)
+c       CALL histwrite_phy(nid_mth,"tops01",itau_w,zx_tmp_2d,
+c    .       iim*jjmp1,ndex2d)
+c     ENDIF !itap.EQ.ecrit_mth 
+c
+c220404 BEG
+c
+c temperature tendency due to total diabatic heating
+       DO l=1, klev
+       DO i=1, klon
+       d_t(i,l) = (t_seri(i,l)-t(i,l))/dtime
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdia",itau_w,d_t)
+c
+c temperature tendency due to SW radiation
+       DO l=1, klev
+       DO i=1, klon
+       zx_tmp_fi3d(i,l)=heat(i,l)/RDAY
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw",itau_w,zx_tmp_fi3d)
+c
+c temperature tendency due to LW radiation
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=-1*cool(i,l)/RDAY
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw",itau_w,zx_tmp_fi3d)
+c
+
+c
+c  temperature tendency due to large scale precipitation
+       DO l=1, klev
+       DO i=1, klon
+       zx_tmp_fi3d(i,l)=d_t_lsc(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlsc",itau_w,zx_tmp_fi3d)
+c
+c  total moisture tendency due to diabatic processes
+       DO l=1, klev
+       DO i=1, klon
+        d_qx(i,l,ivap) = ( q_seri(i,l) - qx(i,l,ivap) ) / dtime
+        zx_tmp_fi3d(i,l)=d_qx(i,l,ivap)
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdia",itau_w,zx_tmp_fi3d)
+c
+cBEG 210404 BEG
+c
+      IF(ok_orodr.AND.ok_orolf) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = (d_u_oro(i,k) + d_u_lif(i,k))/pdtphys
+        d_v_oli(i,k) = (d_v_oro(i,k) + d_v_lif(i,k))/pdtphys
+      ENDDO
+      ENDDO
+      ENDIF !(ok_orodr.AND.ok_orolf) THEN
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_u_oli,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoli",itau_w,d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_v_oli,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoli",itau_w,d_v_oli)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ducon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvcon",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_u,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dutot",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_v,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvtot",itau_w,d_v)
+
+cEND 210404 END
+c
+c cldtrue
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldtrue,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldtrue",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldTOA,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldTOA",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldSFC,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldSFC",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+      DO i=1, klon
+cIM 151004    zx_tmp_fi2d(i)=GWDtaux1(i,1)-GWDtaux0(i,1)
+       zx_tmp_fi2d(i)=zustrdr(i)+zustrli(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"GWDtaux",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+cIM 151004    zx_tmp_fi2d(i)=GWDtauy1(i,1)-GWDtauy0(i,1)
+       zx_tmp_fi2d(i)=zvstrdr(i)+zvstrli(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"GWDtauy",itau_w,zx_tmp_fi2d)
+c
+c220404 END
+cAMIP2 END
+c
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m",itau_w,zt2m)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"t2m_min",itau_w,zt2m)
+c
+cym     CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"t2m_max",itau_w,zt2m)
+c
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"tsoil",itau_w,zx_tmp_2d,
+c    .               iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sicf",itau_w,zx_tmp_fi2d)
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"temp",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+c ENSEMBLES END
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"v10m",itau_w,zv10m)
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"psol",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"qsurf",itau_w,zxqsurf)
+c
+      if (.not. ok_veget) then
+cym          CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d)
+          CALL histwrite_phy(nid_mth,"qsol",itau_w,qsol)
+      endif
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"ndayrain",itau_w,nday_rain)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"snowf",itau_w,snow_fall)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl0",itau_w,toplw0)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+c
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200",itau_w,SWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200clr",itau_w,SWup200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200",itau_w,SWdn200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200clr",itau_w,SWdn200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200",itau_w,LWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200clr",itau_w,LWup200clr)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200clr",itau_w,zx_tmp_fi2d)
+c
+c200 END 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll0",itau_w,sollw0)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       sollwdownclr(i)=-1.*lwdn0(i,1)
+      ENDDO !i=1, klon
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)-sollwdownclr(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFC",itau_w,sollwdown)
+c
+c     DO i=1, klon
+cIM 08004    sollwdownclr(i)=lwdn0(i,1)
+c      sollwdownclr(i)=-1.*lwdn0(i,1)
+c     ENDDO !i=1, klon
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFCclr",itau_w,sollwdownclr)
+c effets des aerosols
+c
+      IF (ok_ade.OR.ok_aie) THEN
+      zx_tmp_fi2d(1:klon) = topswai(1:klon) - topswad(1:klon)
+      CALL histwrite_phy(nid_mth,"topsad",itau_w,zx_tmp_2d)
+c
+      zx_tmp_fi2d(1:klon) = solswai(1:klon) - solswad(1:klon)
+      CALL histwrite_phy(nid_mth,"solsad",itau_w,zx_tmp_2d)
+c
+      zx_tmp_fi2d(1:klon) = topsw(1:klon) - topswai(1:klon)
+      CALL histwrite_phy(nid_mth,"topsai",itau_w,zx_tmp_2d)
+c
+      zx_tmp_fi2d(1:klon) = solsw(1:klon) - solswai(1:klon)
+      CALL histwrite_phy(nid_mth,"solsai",itau_w,zx_tmp_2d)
+      endif
+
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fder",itau_w,fder)
+c
+c Effets des aerosols
+c
+      IF (ok_ade.OR.ok_aie) THEN
+        zx_tmp_fi2d(1:klon) = topswai(1:klon) - topswad(1:klon)
+        CALL histwrite_phy(nid_mth,"topsad",itau_w,zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1:klon) = solswai(1:klon) - solswad(1:klon)
+        CALL histwrite_phy(nid_mth,"solsad",itau_w,zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1:klon) = topsw(1:klon) - topswai(1:klon)
+        CALL histwrite_phy(nid_mth,"topsai",itau_w,zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1:klon) = solsw(1:klon) - solswai(1:klon)
+        CALL histwrite_phy(nid_mth,"solsai",itau_w,zx_tmp_fi2d)
+      ENDIF
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite_phy(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite_phy(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"ffonte",itau_w,zxffonte)
+c
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqcalving",itau_w,zxfqcalving)
+c
+       DO nsrf = 1, nbsrf
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDDO
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_oce)*100.
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_oce),itau_w,
+     $      zx_tmp_fi2d) 
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_oce)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_oce),itau_w,
+     $      zx_tmp_fi2d) 
+c
+      DO nsrf = 1, nbsrf
+CYYY
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       IF(1.EQ.0) THEN
+C
+        zx_tmp_fi2d(1:klon) = fevap(1:klon,nsrf)*pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"evapour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1:klon) = (rain_fall(1:klon) + snow_fall(1:klon))
+     $                        *pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"prepour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       ENDIF !(1.EQ.0) THEN
+C
+      END DO  
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt*100.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldt",itau_w,cldt*100.)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldq",itau_w,cldq)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ue",itau_w,ue)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ve",itau_w,ve)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"uq",itau_w,uq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"vq",itau_w,vq)
+cKE43
+      IF (iflag_con.GE.3) THEN ! sb
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cape",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pbase",itau_w,pbase)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ptop",itau_w,ema_pct)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fbase",itau_w,ema_cbmf)
+c
+c34EK
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"prw",itau_w,prw)
+c
+      ENDIF !iflag_con.GE.3
+c
+cIM cf. AM 081204 BEG
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c  Champs interpolles sur des niveaux de pression
+c     DO k=1, nlevENS
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+       IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"u"//bb2,itau_w,usumSTD(:,k,2))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"v"//bb2,itau_w,vsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"w"//bb2,itau_w,wsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phi"//bb2,itau_w,phisumSTD(:,k,2))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700"
+      ENDDO !nlevSTD
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     .     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ 
+     .                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     .                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t_oce_sic",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lmt_bils",itau_w,
+     .     zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slab_bils",itau_w,
+     .     zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"siceh",itau_w,seaice/1000.)
+c
+      ENDIF !OCEAN.EQ.force/slab
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+C
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"iwcon",itau_w,fiwc)
+c
+c#ifdef histmthNMC
+c#include "write_histmthNMC.h"
+c#endif
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ovap",itau_w, qx(:,:,ivap))
+c
+c     zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/
+c    .                         (1-qx(1:klon,1:klev,ivap))
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"wvap",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra*100., zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rneb",itau_w,cldfra*100.)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rhum",itau_w,zx_rh)
+c
+      DO k=1, klev
+       DO i=1, klon
+cIM 151004        zx_tmp_fi3d(i,k)=MAX(wo(i,k),1.0e-12)*RG/46.6968
+c    $                    /(paprs(i,k)-paprs(i,k+1))
+c    $                    *(paprs(i,1)/101325.0)
+c        zx_tmp2_fi3d(i,k)=MAX(wo(i,k)*1.0e+6,1.0e-6)*RG/46.6968
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp2_fi3d,zx_tmp_3d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ozone",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap),zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqphy",itau_w,d_qx(:,:,ivap))
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+       DO nsrf=1, nbsrf
+c
+        zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ages_"//clnsurf(nsrf),itau_w
+     $    ,agesno)
+c
+      ENDDO !nsrf=1, nbsrf
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albs",itau_w,albsol1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albslw",itau_w,albsol2)
+c
+      ENDIF !lev_histmth.GE.3
+c
+c
+      IF(lev_histmth.GE.4) THEN
+c
+c  FH Sorties pour la couche limite
+      CALL histwrite_phy(nid_mth,"kz",itau_w,ycoefh)
+      CALL histwrite_phy(nid_mth,"kz_max",itau_w,ycoefh)
+
+      if(iflag_pbl>1) then
+      zx_tmp_fi3d=0.
+      do nsrf=1,nbsrf
+         do k=1,klev
+          zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k)
+     ,    +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+         enddo
+      enddo
+      CALL histwrite_phy(nid_mth,"tke",itau_w,zx_tmp_fi3d)
+      CALL histwrite_phy(nid_mth,"tke_max",itau_w,zx_tmp_fi3d)
+      endif
+
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"clwcon",itau_w,clwcon0)
+c
+      IF (iflag_con.GE.3) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"Ma",itau_w,Ma)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"upwd",itau_w,upwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd",itau_w,dnwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd0",itau_w,dnwd0)
+c
+      ENDIF !iflag_con.GE.3
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdyn",itau_w,d_q_dyn)
+c
+cIM: 101003 : K/30min ==> K/s
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqcon",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     .                             d_t_eva(1:klon,1:klev))/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlschr",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqlsc",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqvdf",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dteva",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqeva",itau_w,zx_tmp_fi3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ptconv",itau_w,zpt_conv)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ratqs",itau_w,ratqs)
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtajs",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqajs",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqthe",itau_w,zx_tmp_fi3d)
+c
+c
+cIM: 101003 : K/day ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY 
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtswr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlwr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : deja en K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtec",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvvdf",itau_w,zx_tmp_fi3d)
+c
+      IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoro",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoro",itau_w,zx_tmp_fi3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dulif",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvlif",itau_w,zx_tmp_fi3d)
+      ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      CALL histwrite_phy(nid_mth,"tau",itau_w,cldtau)
+      CALL histwrite_phy(nid_mth,"CCM1",itau_w,ccm(:,:,1))
+      CALL histwrite_phy(nid_mth,"CCM2",itau_w,ccm(:,:,2))
+      CALL histwrite_phy(nid_mth,"taupi",itau_w,cldtaupi)
+      CALL histwrite_phy(nid_mth,"cldemi",itau_w,cldemi)
+      CALL histwrite_phy(nid_mth,"SWTOAAS_ZERO",itau_w,topsw_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AER",itau_w,topsw_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_NAT",itau_w,topsw_inca(:,3))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AD",itau_w,topswad_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AI",itau_w,topswai_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_ZERO",itau_w,topsw0_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AER",itau_w,topsw0_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AD",itau_w,topswad0_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_NAT",itau_w,topsw0_inca(:,3))
+#endif
+#ifndef INCA
+      IF (nqmax.GE.3) THEN
+      DO iq=3,nqmax
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq), zx_tmp_3d)
+         CALL histwrite_phy(nid_mth,tnom(iq),itau_w,qx(:,:,iq))
+      ENDDO
+      ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ENDIF !(type_run.EQ."AMIP")
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_mth)
+c$OMP END MASTER
+      endif
+c
+      ENDIF !ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histmthNMC.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histmthNMC.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histmthNMC.h	(revision 984)
@@ -0,0 +1,126 @@
+!
+! $Header$
+!
+      IF (ok_mensuel) THEN
+c
+       ndex3d = 0
+       itau_w = itau_phy + itap
+ccc
+c  Champs interpolles sur des niveaux de pression du NMC
+c
+c     PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+ccc
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+ccc
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,2),
+cym     $      zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,2))
+ccc
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+ccc
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"w",itau_w,wsumSTD(:,:,3))
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,3).NE.1.E+20) THEN
+          zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,3))/ecrit_hf2mth
+         ELSE
+          zx_tmp_fiNC(i,k) = 1.E+20
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,zx_tmp_fiNC,zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"psbg",itau_w,zx_tmp_fiNC)
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,uvsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"uv",itau_w,uvsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vqsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vq",itau_w,vqsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vTsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vT",itau_w,vTsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1, wqsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"wq",itau_w,wqsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vphisumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vphi",itau_w,vphisumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wTsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"wT",itau_w,wTsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,u2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"uxu",itau_w,u2sumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,v2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vxv",itau_w,v2sumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,T2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"TxT",itau_w,T2sumSTD(:,:,3))
+c
+      ENDIF !type_run
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_nmc)
+c$OMP END MASTER
+      endif
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_histrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_histrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_histrac.h	(revision 984)
@@ -0,0 +1,107 @@
+!
+! $Header$
+!
+
+      IF (config_inca == 'none') THEN
+      ndex = 0
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + nstep
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_tra,"phis",itau_w,pphis)
+C
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,airephy,zx_tmp_2d)      
+      CALL histwrite_phy(nid_tra,"aire",itau_w,airephy)
+
+      DO it=1,nqmax
+C champs 2D
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,tr_seri(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,tnom(it+2),itau_w,tr_seri(:,:,it))
+       if (lessivage) THEN
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"fl"//tnom(it+2),itau_w,
+     .                                   flestottr(:,:,it))
+      endif
+      
+c----Olivia
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_th(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_th_"//tnom(it+2),itau_w,
+     .                                           d_tr_th(:,:,it))
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cv(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_cv_"//tnom(it+2),itau_w,
+     .                                           d_tr_cv(:,:,it))
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cl(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_cl_"//tnom(it+2),itau_w,
+     .                                           d_tr_cl(:,:,it))
+c---fin Olivia      
+      
+      ENDDO
+
+
+C abder
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,yu1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"pyu1",itau_w,yu1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,yv1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"pyv1",itau_w,yv1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol1",itau_w,pftsol1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol2,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol2",itau_w,pftsol2)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol3,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol3",itau_w,pftsol3)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol4,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol4",itau_w,pftsol4)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf1",itau_w,ppsrf1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf2,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf2",itau_w,ppsrf2)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf3,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf3",itau_w,ppsrf3)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf4,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf4",itau_w,ppsrf4)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pplay,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"pplay",itau_w,pplay)
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,t_seri,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"t",itau_w,t_seri)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfu,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"mfu",itau_w,pmfu)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfd,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"mfd",itau_w,pmfd)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_u,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"en_u",itau_w,pen_u)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_d,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"en_d",itau_w,pen_d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_d,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"de_d",itau_w,pde_d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_u,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"de_u",itau_w,pde_u)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,coefh,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"coefh",itau_w,coefh)
+
+
+c abder
+
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_tra)
+c$OMP END MASTER
+       endif
+
+       END IF
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phylmd/write_paramLMDZ_phy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/write_paramLMDZ_phy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/write_paramLMDZ_phy.h	(revision 984)
@@ -0,0 +1,366 @@
+c
+      IF (is_sequential) THEN
+      
+      ndex2d = 0
+      itau_w = itau_phy + itap
+c
+c Variables type caractere : plusieurs valeurs possibles
+c
+      IF(ocean.EQ.'force ') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE IF(ocean.EQ.'slab  ') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=2.
+      ELSE IF(ocean.EQ.'couple') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=3.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ocean",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_slab_sicOBS) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_slab_sicOBS",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(type_run.EQ.'CLIM'.OR.type_run.EQ.'ENSP') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE IF(type_run.EQ.'AMIP'.OR.type_run.EQ.'CFMI') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=2.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"type_run",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c Variables logiques (1=true, 2=false)
+c
+      IF(ok_veget) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_veget",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_journe) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_journe",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_mensuel) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_mensuel",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_instan) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_instan",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_ade) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_ade",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_aie) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_aie",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+
+c
+c Champs 2D:
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=bl95_b0
+      CALL histwrite(nid_ctesGCM,"bl95_b0",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=bl95_b1
+      CALL histwrite(nid_ctesGCM,"bl95_b1",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ip_ebil_phy
+      CALL histwrite(nid_ctesGCM,"ip_ebil_phy",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_ecc
+      CALL histwrite(nid_ctesGCM,"R_ecc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_peri
+      CALL histwrite(nid_ctesGCM,"R_peri",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_incl
+      CALL histwrite(nid_ctesGCM,"R_incl",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=solaire
+      CALL histwrite(nid_ctesGCM,"solaire",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=co2_ppm
+      CALL histwrite(nid_ctesGCM,"co2_ppm",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CH4_ppb
+      CALL histwrite(nid_ctesGCM,"CH4_ppb",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=N2O_ppb
+      CALL histwrite(nid_ctesGCM,"N2O_ppb",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CFC11_ppt
+      CALL histwrite(nid_ctesGCM,"CFC11_ppt",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CFC12_ppt
+      CALL histwrite(nid_ctesGCM,"CFC12_ppt",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=epmax
+      CALL histwrite(nid_ctesGCM,"epmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Mais est-il bien raisonable de stoker ces fichiers comme des
+! champs 2D...
+! WARNING :
+! Il faudrait ici ajoute l'ecriture des champs
+!      cycle_diurne = cycle_diurne_omp
+!   soil_model = soil_model_omp
+!   new_oliq = new_oliq_omp
+!   ok_orodr = ok_orodr_omp
+!   ok_orolf = ok_orolf_omp
+!   ok_limitvrai = ok_limitvrai_omp
+!   nbapp_rad = nbapp_rad_omp
+!   iflag_con = iflag_con_omp
+! qui se trouvaient auparavant dans gcm.def et maintenant dans 
+! physiq.def.
+! Mais regarder d'abord a quoi ca sert ...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+c
+      IF(ok_adj_ema) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_adj_ema",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_clw
+      CALL histwrite(nid_ctesGCM,"iflag_clw",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_lsc
+      CALL histwrite(nid_ctesGCM,"cld_lc_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_con
+      CALL histwrite(nid_ctesGCM,"cld_lc_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_lsc
+      CALL histwrite(nid_ctesGCM,"cld_tau_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_con
+      CALL histwrite(nid_ctesGCM,"cld_tau_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ffallv_lsc
+      CALL histwrite(nid_ctesGCM,"ffallv_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ffallv_con
+      CALL histwrite(nid_ctesGCM,"ffallv_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=coef_eva
+      CALL histwrite(nid_ctesGCM,"coef_eva",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(reevap_ice) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"reevap_ice",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_cldcon
+      CALL histwrite(nid_ctesGCM,"iflag_cldcon",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_pdf
+      CALL histwrite(nid_ctesGCM,"iflag_pdf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=fact_cldcon
+      CALL histwrite(nid_ctesGCM,"fact_cldcon",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=facttemps
+      CALL histwrite(nid_ctesGCM,"facttemps",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_newmicro) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_newmicro",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ratqsbas
+      CALL histwrite(nid_ctesGCM,"ratqsbas",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ratqshaut
+      CALL histwrite(nid_ctesGCM,"ratqshaut",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_froid
+      CALL histwrite(nid_ctesGCM,"rad_froid",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_chau1
+      CALL histwrite(nid_ctesGCM,"rad_chau1",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_chau2
+      CALL histwrite(nid_ctesGCM,"rad_chau2",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=top_height
+      CALL histwrite(nid_ctesGCM,"top_height",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=overlap
+      CALL histwrite(nid_ctesGCM,"overlap",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cdmmax
+      CALL histwrite(nid_ctesGCM,"cdmmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cdhmax
+      CALL histwrite(nid_ctesGCM,"cdhmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ksta
+      CALL histwrite(nid_ctesGCM,"ksta",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ksta_ter
+      CALL histwrite(nid_ctesGCM,"ksta_ter",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_kzmin) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_kzmin",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_pbl
+      CALL histwrite(nid_ctesGCM,"iflag_pbl",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histhf
+      CALL histwrite(nid_ctesGCM,"lev_histhf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histday
+      CALL histwrite(nid_ctesGCM,"lev_histday",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histmth
+      CALL histwrite(nid_ctesGCM,"lev_histmth",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_isccp) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_isccp",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lonmin_ins
+      CALL histwrite(nid_ctesGCM,"lonmin_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lonmax_ins
+      CALL histwrite(nid_ctesGCM,"lonmax_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=latmin_ins
+      CALL histwrite(nid_ctesGCM,"latmin_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=latmax_ins
+      CALL histwrite(nid_ctesGCM,"latmax_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ins
+      CALL histwrite(nid_ctesGCM,"ecrit_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_hf
+      CALL histwrite(nid_ctesGCM,"ecrit_hf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_day
+      CALL histwrite(nid_ctesGCM,"ecrit_day",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_mth
+      CALL histwrite(nid_ctesGCM,"ecrit_mth",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_tra
+      CALL histwrite(nid_ctesGCM,"ecrit_tra",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_reg
+      CALL histwrite(nid_ctesGCM,"ecrit_reg",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=freq_ISCCP
+      CALL histwrite(nid_ctesGCM,"freq_ISCCP",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ISCCP
+      CALL histwrite(nid_ctesGCM,"ecrit_ISCCP",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_ctesGCM)
+      endif
+c
+      ENDIF ! mono_cpu
Index: LMDZ4/tags/LF_20080728/libf/phylmd/yamada.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/yamada.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/yamada.F	(revision 984)
@@ -0,0 +1,173 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer l_mix,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      save first
+      data first/.true./
+
+
+      integer ig,k
+
+      real ri,zrif,zalpha,zsm
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real l(klon,klev+1),l0(klon)
+
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/
+
+      real frif,falpha,fsm
+
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+         print*,ri,rif,zalpha,zsm
+      enddo
+      first=.false.
+      endif
+
+c  Correction d'un bug sauvage a verifier.
+c      do k=2,nlev
+      do k=2,nlay
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1))
+     s            /(teta(ig,k-1)+teta(ig,k))  /dz(ig,k)
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+c iterration pour determiner la longueur de melange
+
+                                                          do ig=1,ngrid
+      l0(ig)=100.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+c(abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+                                                          enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/yamada4.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/yamada4.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/yamada4.F	(revision 984)
@@ -0,0 +1,493 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar
+     s   ,iflag_pbl)
+      use dimphy
+      IMPLICIT NONE
+#include "iniprint.h"
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c  iflag_pbl doit valoir entre 6 et 9
+c      l=6, on prend  systematiquement une longueur d'equilibre
+c    iflag_pbl=6 : MY 2.0
+c    iflag_pbl=7 : MY 2.0.Fournier
+c    iflag_pbl=8 : MY 2.5
+c    iflag_pbl=9 : un test ?
+
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),qpre
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+
+      REAL km(klon,klev+1)
+      REAL kmpre(klon,klev+1),tmp2
+      REAL mpre(klon,klev+1)
+      REAL kn(klon,klev+1)
+      REAL kq(klon,klev+1)
+      real ff(klon,klev+1),delta(klon,klev+1)
+      real aa(klon,klev+1),aa0,aa1
+      integer iflag_pbl,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      integer ipas
+      save first,ipas
+cFH/IM     data first,ipas/.true.,0/
+      data first,ipas/.false.,0/
+c$OMP THREADPRIVATE( first,ipas)
+
+      integer ig,k
+
+
+      real ri,zrif,zalpha,zsm,zsn
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real dtetadz(klon,klev+1)
+      real m2cstat,mcstat,kmcstat
+      real l(klon,klev+1)
+      real,allocatable,save :: l0(:)
+c$OMP THREADPRIVATE(l0)      
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
+c$OMP THREADPRIVATE(ric,rifc,b1,kap)
+      real frif,falpha,fsm
+      real fl,zzz,zl0,zq2,zn2
+
+cym      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
+cym     s  ,lyam(klon,klev),knyam(klon,klev)
+cym     s  ,w2yam(klon,klev),t2yam(klon,klev)
+      real,allocatable,save,dimension(:,:) :: rino,smyam,styam,lyam,
+     s                                        knyam,w2yam,t2yam
+cym      common/pbldiag/rino,smyam,styam,lyam,knyam,w2yam,t2yam
+c$OMP THREADPRIVATE(rino,smyam,styam,lyam,knyam,w2yam,t2yam)
+      logical,save :: firstcall=.true.
+c$OMP THREADPRIVATE(firstcall)       
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+      fl(zzz,zl0,zq2,zn2)=
+     s     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
+
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (firstcall) then
+        allocate(rino(klon,klev+1),smyam(klon,klev),styam(klon,klev))
+        allocate(lyam(klon,klev),knyam(klon,klev))
+        allocate(w2yam(klon,klev),t2yam(klon,klev))
+	allocate(l0(klon))
+	firstcall=.false.
+      endif
+
+
+      if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.9)) then
+           stop'probleme de coherence dans appel a MY'
+      endif
+
+      ipas=ipas+1
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+c     print*,ri,rif,zalpha,zsm
+      enddo
+      endif
+
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO ig=1,ngrid
+            zlev(ig,nlev)=zlay(ig,nlay)
+     &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
+                                                      ENDDO
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO k=1,nlay
+                                                      DO ig=1,ngrid
+        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+                                                      ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
+                                                      ENDDO
+      DO k=2,nlay
+                                                      DO ig=1,ngrid
+        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+                                                     ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+                                                     ENDDO
+c
+c.......................................................................
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
+         n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
+c        n2(ig,k)=0.
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+c     print*,'RIF L=',k,rif(ig,k),ri*alpha(ig,k)
+
+
+                                                          enddo
+      enddo
+
+
+c====================================================================
+c   Au premier appel, on determine l et q2 de facon iterative.
+c iterration pour determiner la longueur de melange
+
+
+      if (first.or.iflag_pbl.eq.6) then
+                                                          do ig=1,ngrid
+      l0(ig)=10.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+c        l0(ig)=30.
+                                                          enddo
+c      print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+c     print*,'Fin de l initialisation de q2 et l0'
+
+      endif ! first
+
+c====================================================================
+c  Calcul de la longueur de melange.
+c====================================================================
+
+c   Mise a jour de l0
+                                                          do ig=1,ngrid
+      sq(ig)=1.e-10
+      sqz(ig)=1.e-10
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        zq=sqrt(q2(ig,k))
+        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+      enddo
+                                                          do ig=1,ngrid
+      l0(ig)=0.2*sqz(ig)/sq(ig)
+c        l0(ig)=30.
+                                                          enddo
+c      print*,'ITER=',iter,'  L0=',l0
+c   calcul de l(z)
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+         if(first) then
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         endif
+                                                          enddo
+      enddo
+
+c====================================================================
+c   Yamada 2.0
+c====================================================================
+      if (iflag_pbl.eq.6) then
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+                                                          enddo
+      enddo
+
+
+      else if (iflag_pbl.eq.7) then
+c====================================================================
+c   Yamada 2.Fournier
+c====================================================================
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         mpre(ig,k)=sqrt(m2(ig,k))
+c        print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+                                                          enddo
+      enddo
+
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12)
+        mcstat=sqrt(m2cstat)
+
+c        print*,'M2 L=',k,mpre(ig,k),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (k.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)
+     &              *cd(ig)
+     &              *( sqrt(u(ig,3)**2+v(ig,3)**2)
+     &                -mcstat/unsdzdec(ig,k)
+     &                -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2)
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)*kmpre(ig,k-1)
+     &                          *mpre(ig,k-1) )
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ENDIF
+c       print*,'T2 L=',k,tmp2
+        tmp2=kmcstat
+     &      /( sm(ig,k)/q2(ig,k) )
+     &      /l(ig,k)
+        q2(ig,k)=max(tmp2,1.e-12)**(2./3.)
+c       print*,'Q2 L=',k,q2(ig,k)
+c
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl.ge.8) then
+c====================================================================
+c   Yamada 2.5 a la Didi
+c====================================================================
+
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         if (delta(ig,k).lt.1.e-20) then
+c     print*,'ATTENTION   L=',k,'   Delta=',delta(ig,k)
+            delta(ig,k)=1.e-20
+         endif
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         aa0=
+     s   (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+         aa1=
+     s   (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+c abder      print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20)
+         aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k))
+c     print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+         qpre=sqrt(q2(ig,k))
+         if (iflag_pbl.eq.8 ) then
+            if (aa(ig,k).gt.0.) then
+               q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+         else ! iflag_pbl=9
+            if (aa(ig,k)*qpre.gt.0.9) then
+               q2(ig,k)=(qpre*10.)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+         endif
+         q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4)
+c     print*,'Q2 L=',k,q2(ig,k),qpre*qpre
+                                                          enddo
+      enddo
+
+      endif ! Fin du cas 8
+
+c     print*,'OK8'
+
+c====================================================================
+c   Calcul des coefficients de m�ange
+c====================================================================
+      do k=2,klev
+c     print*,'k=',k
+                                                          do ig=1,ngrid
+cabde      print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k)
+         zq=sqrt(q2(ig,k))
+         km(ig,k)=l(ig,k)*zq*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+         kq(ig,k)=l(ig,k)*zq*0.2
+c     print*,'KML=',km(ig,k),kn(ig,k)
+                                                          enddo
+      enddo
+
+c     if (iflag_pbl.ge.7..and.0.eq.1) then
+c        q2(:,1)=q2(:,2)
+c        call vdif_q2(dt,g,rconst,plev,temp,kq,q2)
+c     endif
+
+c   Traitement des cas noctrunes avec l'introduction d'une longueur
+c   minilale.
+
+c====================================================================
+c   Traitement particulier pour les cas tres stables.
+c   D'apres Holtslag Boville.
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 0'
+      endif !(prt_level>1) THEN
+                                                          do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+                                                          enddo
+
+!      print*,'pblhmin ',pblhmin
+CTest a remettre 21 11 02
+c test abd 13 05 02      if(0.eq.1) then
+      if(1.eq.1) then
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+c   la longueur de melange est suposee etre l= kap z
+c   K=l q Sm d'ou q2=(K/l Sm)**2
+               q2(ig,k)=(qmin/sm(ig,k))**2
+            endif
+         enddo
+      enddo
+      endif
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 1'
+      endif !(prt_level>1) THEN
+c   Diagnostique pour stokage
+
+      if(1.eq.0)then
+      rino=rif
+      smyam(1:ngrid,1)=0.
+      styam(1:ngrid,1)=0.
+      lyam(1:ngrid,1)=0.
+      knyam(1:ngrid,1)=0.
+      w2yam(1:ngrid,1)=0.
+      t2yam(1:ngrid,1)=0.
+
+      smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)
+      styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev)
+      lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev)
+      knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev)
+
+c   Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+
+      w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24
+     s    +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev)
+     s    *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev))
+
+      t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev)
+     s    *dtetadz(1:ngrid,2:klev)**2
+     s    /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev)
+      endif
+
+c     print*,'OKFIN'
+      first=.false.
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phylmd/zilch.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phylmd/zilch.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phylmd/zilch.F	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      subroutine zilch(x,m)
+c
+c Zero the real array x dimensioned m.
+c
+      implicit none
+c
+      integer m,i
+      real x(m)
+      do 1 i=1,m
+      x(i)= 0.0  
+    1 continue
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/FCTTRE.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/FCTTRE.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/FCTTRE.h	(revision 984)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!     ------------------------------------------------------------------
+!     This COMDECK includes the Thermodynamical functions for the cy39
+!       ECMWF Physics package.
+!       Consistent with YOMCST Basic physics constants, assuming the
+!       partial pressure of water vapour is given by a first order
+!       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
+!       in YOETHF
+!     ------------------------------------------------------------------
+      REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
+      REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
+      LOGICAL thermcep
+      PARAMETER (thermcep=.TRUE.)
+!
+      FOEEW ( PTARG,PDELARG ) = EXP (                                   &
+     &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)        &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+!
+      FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
+!
+      qsats(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (2.07023 - 0.00320991 * ptarg                       &
+     &           - 2484.896 / ptarg + 3.56654 * LOG10(ptarg))
+      qsatl(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (23.8319 - 2948.964 / ptarg                         &
+     &           - 5.028 * LOG10(ptarg)                                 &
+     &           - 29810.16 * EXP( - 0.0699382 * ptarg)                 &
+     &           + 25.21935 * EXP( - 2999.924 / ptarg))
+!
+      dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg         &
+     &                     +2484.896*LOG(10.)/ptarg**2                  &
+     &                     -0.00320991*LOG(10.))
+      dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)*                &
+     &                (2948.964/ptarg**2-5.028/LOG(10.)/ptarg           &
+     &                +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg)  &
+     &                +29810.16*0.0699382*EXP(-0.0699382*ptarg))
Index: LMDZ4/tags/LF_20080728/libf/phytherm/YOECUMF.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/YOECUMF.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/YOECUMF.h	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+C     ----------------------------------------------------------------
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C     ----------------------------------------------------------------
+C
+      COMMON /YOECUMF/
+     L                 LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV,
+     R                 ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,
+     R                 CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON
+C
+      LOGICAL          LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
+      REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
+      REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
+c$OMP THREADPRIVATE(/YOECUMF/)
+C
+*if (DOC,declared) <> 'UNKNOWN'
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C
+C     M.TIEDTKE       E. C. M. W. F.      18/1/89
+C
+C     NAME      TYPE      PURPOSE
+C     ----      ----      -------
+C
+C     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
+C     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
+C     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
+C     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
+C     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
+C     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+C     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
+C     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+C     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+C     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
+C     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
+C     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
+C     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+C     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
+C     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
+C                        FROM CLOUD WATER TO RAIN
+*ifend
+C     ----------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phytherm/YOEGWD.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/YOEGWD.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/YOEGWD.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+C     -----------------------------------------------------------------
+C*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+C     -----------------------------------------------------------------
+C
+      integer NKTOPG,NSTRA
+      real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+      real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC
+      COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+     *        ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC
+c$OMP THREADPRIVATE(/YOEGWD/)
+C
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/YOETHF.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/YOETHF.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/YOETHF.h	(revision 984)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
+!
+!     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
+!                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
+!                ICE(*R_IES*).
+!     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
+!     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
+!
+      REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
+      REAL RVTMP2, RHOH2O
+      COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES,    &
+     &               RVTMP2, RHOH2O
+!$OMP THREADPRIVATE(/YOETHF/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/YOMCST.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/YOMCST.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/YOMCST.h	(revision 984)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! A1.0 Fundamental constants
+      REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO
+! A1.1 Astronomical constants
+      REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
+! A1.1.bis Constantes concernant l'orbite de la Terre:
+      REAL R_ecc, R_peri, R_incl
+! A1.2 Geoide
+      REAL RA,RG,R1SA
+! A1.3 Radiation
+!     REAL RSIGMA,RI0
+      REAL RSIGMA
+! A1.4 Thermodynamic gas phase
+      REAL R,RMD,RMO3,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
+      REAL RKAPPA,RETV
+! A1.5,6 Thermodynamic liquid,solid phases
+      REAL RCW,RCS
+! A1.7 Thermodynamic transition of phase
+      REAL RLVTT,RLSTT,RLMLT,RTT,RATM
+! A1.8 Curve of saturation
+      REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
+      REAL RALPD,RBETD,RGAMD
+!
+      COMMON/YOMCST/RPI   ,RCLUM ,RHPLA ,RKBOL ,RNAVO                   &
+     &      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA                  &
+     &      ,R_ecc, R_peri, R_incl                                      &
+     &      ,RA    ,RG    ,R1SA                                         &
+     &      ,RSIGMA                                                     &
+     &      ,R     ,RMD   ,RMO3  ,RMV   ,RD    ,RV    ,RCPD             &
+     &      ,RCPV  ,RCVD  ,RCVV  ,RKAPPA,RETV                           &
+     &      ,RCW   ,RCS                                                 &
+     &      ,RLVTT ,RLSTT ,RLMLT ,RTT   ,RATM                           &
+     &      ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS            &
+     &      ,RALPD ,RBETD ,RGAMD
+!    ------------------------------------------------------------------
+!$OMP THREADPRIVATE(/YOMCST/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/aaam_bud.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/aaam_bud.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/aaam_bud.F	(revision 984)
@@ -0,0 +1,361 @@
+      subroutine aaam_bud (iam,nlon,nlev,rjour,rsec,
+     i                   rea,rg,ome,      
+     i                   plat,plon,phis,
+     i                   dragu,liftu,phyu,
+     i                   dragv,liftv,phyv,
+     i                   p, u, v,
+     o                   aam, torsfc)
+c
+      implicit none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 20031020
+c Object: Compute different terms of the axial AAAM Budget.
+C No outputs, every AAM quantities are written on the IAM
+C File. 
+c
+c Modif : I.Musat (LMD/CNRS) date : 20041020
+c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc",
+c but no write in the iam file.
+c
+C WARNING: Only valid for regular rectangular grids.
+C REMARK: CALL DANS PHYSIQ AFTER lift_noro:
+C        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+C    C               ra,rg,romega,
+C    C               rlat,rlon,pphis,
+C    C               zustrdr,zustrli,zustrph,
+C    C               zvstrdr,zvstrli,zvstrph,
+C    C               paprs,u,v)
+C
+C======================================================================
+c Explicit Arguments:
+c ==================
+c iam-----input-I-File number where AAMs and torques are written
+c                 It is a formatted file that has been opened
+c                 in physiq.F
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c rjour---input-R-Jour compte depuis le debut de la simu (run.def)
+c rsec----input-R-Seconde de la journee
+c rea-----input-R-Earth radius
+c rg------input-R-gravity constant
+c ome-----input-R-Earth rotation rate
+c plat ---input-R-Latitude en degres
+c plon ---input-R-Longitude en degres
+c phis ---input-R-Geopotential at the ground
+c dragu---input-R-orodrag stress (zonal)
+c liftu---input-R-orolift stress (zonal)
+c phyu----input-R-Stress total de la physique (zonal)
+c dragv---input-R-orodrag stress (Meridional)
+c liftv---input-R-orolift stress (Meridional)
+c phyv----input-R-Stress total de la physique (Meridional)
+c p-------input-R-Pressure (Pa) at model half levels
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c aam-----output-R-Axial Wind AAM (=raam(3))
+c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                iim*(jjm-1)+2 for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c dlat-----R: Latitude increment (Radians)
+c dlon-----R: Longitude increment (Radians)
+c raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c tmou-----R: Resolved Mountain torque (3 components)
+c tsso-----R: Parameterised Moutain drag torque (3 components)
+c tbls-----R: Parameterised Boundary layer torque (3 components)
+c
+c LOCAL ARRAY:
+c ===========
+c zs    ---R: Topographic height
+c ps    ---R: Surface Pressure  
+c ub    ---R: Barotropic wind zonal
+c vb    ---R: Barotropic wind meridional
+c zlat  ---R: Latitude in radians
+c zlon  ---R: Longitude in radians
+c======================================================================
+
+#include "dimensions.h"
+#include "dimphy.h"
+c
+c ARGUMENTS
+c
+      INTEGER iam,nlon,nlev
+      REAL rjour,rsec,rea,rg,ome
+      REAL plat(nlon),plon(nlon),phis(nlon)
+      REAL dragu(nlon),liftu(nlon),phyu(nlon)             
+      REAL dragv(nlon),liftv(nlon),phyv(nlon)             
+      REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev)
+c
+c Variables locales:
+c
+      INTEGER i,j,k,l
+      REAL xpi,hadley,hadday
+      REAL dlat,dlon
+      REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3)
+      integer iax
+cIM ajout aam, torsfc
+c aam = composante axiale du Wind AAM raam
+c torsfc = composante axiale de (tmou+tsso+tbls)
+      REAL aam, torsfc
+
+      REAL ZS(801,401),PS(801,401)
+      REAL UB(801,401),VB(801,401)
+      REAL SSOU(801,401),SSOV(801,401)
+      REAL BLSU(801,401),BLSV(801,401)
+      REAL ZLON(801),ZLAT(401)
+C
+C  PUT AAM QUANTITIES AT ZERO:
+C
+      if(iim+1.gt.801.or.jjm+1.gt.401)then
+      print *,' Pb de dimension dans aaam_bud'
+      stop
+      endif
+
+      xpi=acos(-1.)
+      hadley=1.e18
+      hadday=1.e18*24.*3600.
+      dlat=xpi/float(jjm)
+      dlon=2.*xpi/float(iim) 
+      
+      do iax=1,3
+      oaam(iax)=0.
+      raam(iax)=0.
+      tmou(iax)=0.
+      tsso(iax)=0.
+      tbls(iax)=0.
+      enddo
+
+C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
+
+C North pole values (j=1):
+ 
+      l=1
+
+        ub(1,1)=0.
+        vb(1,1)=0.
+        do k=1,nlev
+          ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+          vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+        enddo
+
+          zlat(1)=plat(l)*xpi/180.
+
+        do i=1,iim+1
+
+          zs(i,1)=phis(l)/rg
+          ps(i,1)=p(l,1)
+          ub(i,1)=ub(1,1)                             
+          vb(i,1)=vb(1,1)                             
+          ssou(i,1)=dragu(l)+liftu(l)
+          ssov(i,1)=dragv(l)+liftv(l)
+          blsu(i,1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,1)=phyv(l)-dragv(l)-liftv(l)
+
+        enddo
+
+
+      do j = 2,jjm
+
+C Values at Greenwich (Periodicity)
+
+      zs(iim+1,j)=phis(l+1)/rg
+      ps(iim+1,j)=p(l+1,1)
+          ssou(iim+1,j)=dragu(l+1)+liftu(l+1)
+          ssov(iim+1,j)=dragv(l+1)+liftv(l+1)
+          blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1)
+          blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1)
+      zlon(iim+1)=-plon(l+1)*xpi/180.
+      zlat(j)=plat(l+1)*xpi/180.
+
+      ub(iim+1,j)=0.
+      vb(iim+1,j)=0.
+         do k=1,nlev
+         ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         enddo
+      
+
+      do i=1,iim
+
+      l=l+1
+      zs(i,j)=phis(l)/rg
+      ps(i,j)=p(l,1)
+          ssou(i,j)=dragu(l)+liftu(l)
+          ssov(i,j)=dragv(l)+liftv(l)
+          blsu(i,j)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,j)=phyv(l)-dragv(l)-liftv(l)
+      zlon(i)=plon(l)*xpi/180.
+
+      ub(i,j)=0.
+      vb(i,j)=0.
+         do k=1,nlev
+         ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+         enddo
+
+      enddo
+
+      enddo
+
+
+C South Pole
+
+      l=l+1
+      ub(1,jjm+1)=0.
+      vb(1,jjm+1)=0.
+      do k=1,nlev
+         ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+      enddo
+      zlat(jjm+1)=plat(l)*xpi/180.
+
+      do i=1,iim+1
+      zs(i,jjm+1)=phis(l)/rg
+      ps(i,jjm+1)=p(l,1)
+          ssou(i,jjm+1)=dragu(l)+liftu(l)
+          ssov(i,jjm+1)=dragv(l)+liftv(l)
+          blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l)
+      ub(i,jjm+1)=ub(1,jjm+1)                               
+      vb(i,jjm+1)=vb(1,jjm+1)                                
+      enddo
+
+C
+C  MOMENT ANGULAIRE 
+C
+        DO j=1,jjm    
+        DO i=1,iim
+
+           raam(1)=raam(1)-rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +cos(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    +rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +sin(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (cos(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +cos(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(2)=raam(2)-rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +sin(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    -rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +cos(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (sin(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +sin(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(3)=raam(3)+rea**3*dlon*dlat*0.5*
+     c           (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1))
+
+           oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5*
+     c        (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1))
+
+        ENDDO
+        ENDDO
+
+C
+C COUPLE DES MONTAGNES:
+C
+
+        DO j=1,jjm
+        DO i=1,iim
+           tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+           tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+        ENDDO
+        ENDDO
+           
+        DO j=2,jjm 
+        DO i=1,iim
+           tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
+           tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
+           tmou(3)=tmou(3)-rea**2*dlat*0.5*
+     c  cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j))
+        ENDDO
+        ENDDO
+
+C
+C COUPLES DES DIFFERENTES FRICTION AU SOL:
+C
+        l=1
+        DO j=2,jjm
+        DO i=1,iim
+        l=l+1
+           tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *sin(zlon(i))
+
+           tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *cos(zlon(i))
+
+           tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *cos(zlat(j))
+
+           tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *sin(zlon(i))
+
+           tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *cos(zlon(i))
+
+           tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *cos(zlat(j))
+
+        ENDDO
+        ENDDO
+            
+
+c     write(*,*) 'AAM',rsec,
+c     write(*,*) 'AAM',rjour+rsec/86400.,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+
+c     write(iam,100)rjour+rsec/86400.,
+c    c      raam(1)/hadday,oaam(1)/hadday,
+c    c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
+c    c      raam(2)/hadday,oaam(2)/hadday,
+c    c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley 
+100   format(F12.5,15(1x,F12.5))
+
+c     write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1)
+c
+      aam=raam(3)
+      torsfc= tmou(3)+tsso(3)+tbls(3)
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/aeropt.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/aeropt.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/aeropt.F	(revision 984)
@@ -0,0 +1,134 @@
+!
+! $Header$
+!
+      SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl,
+     .            tau_ae, piz_ae, cg_ae, ai        )
+c
+      USE dimphy
+      IMPLICIT none
+c
+c
+c     
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev), t_seri(klon,klev)
+      REAL msulfate(klon,klev) ! masse sulfate ug SO4/m3  [ug/m^3]
+      REAL RHcl(klon,klev)     ! humidite relative ciel clair
+      REAL tau_ae(klon,klev,2) ! epaisseur optique aerosol
+      REAL piz_ae(klon,klev,2) ! single scattering albedo aerosol
+      REAL cg_ae(klon,klev,2)  ! asymmetry parameter aerosol
+      REAL ai(klon)            ! POLDER aerosol index 
+c
+c Local
+c
+      INTEGER i, k, inu
+      INTEGER RH_num, nbre_RH
+      PARAMETER (nbre_RH=12)
+      REAL RH_tab(nbre_RH)
+      REAL RH_MAX, DELTA, rh 
+      PARAMETER (RH_MAX=95.)
+      DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+      REAL zrho, zdz
+      REAL taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
+      REAL taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
+      REAL alpha_aer_sulfate(nbre_RH,5)   !--unit m2/g SO4
+      REAL alphasulfate      
+c
+c Proprietes optiques
+c
+      REAL alpha_aer(nbre_RH,2)   !--unit m2/g SO4
+      REAL cg_aer(nbre_RH,2)
+      DATA alpha_aer/.500130E+01,  .500130E+01,  .500130E+01,  
+     .               .500130E+01,  .500130E+01,  .616710E+01,  
+     .               .826850E+01,  .107687E+02,  .136976E+02,  
+     .               .162972E+02,  .211690E+02,  .354833E+02,  
+     .               .139460E+01,  .139460E+01,  .139460E+01,  
+     .               .139460E+01,  .139460E+01,  .173910E+01,  
+     .               .244380E+01,  .332320E+01,  .440120E+01,  
+     .               .539570E+01,  .734580E+01,  .136038E+02 / 
+      DATA cg_aer/.619800E+00,  .619800E+00,  .619800E+00,  
+     .            .619800E+00,  .619800E+00,  .662700E+00,  
+     .            .682100E+00,  .698500E+00,  .712500E+00,  
+     .            .721800E+00,  .734600E+00,  .755800E+00,  
+     .            .545600E+00,  .545600E+00,  .545600E+00,  
+     .            .545600E+00,  .545600E+00,  .583700E+00,  
+     .            .607100E+00,  .627700E+00,  .645800E+00,  
+     .            .658400E+00,  .676500E+00,  .708500E+00 / 
+      DATA alpha_aer_sulfate/
+     . 4.910,4.910,4.910,4.910,6.547,7.373,
+     . 8.373,9.788,12.167,14.256,17.924,28.433,
+     . 1.453,1.453,1.453,1.453,2.003,2.321,
+     . 2.711,3.282,4.287,5.210,6.914,12.305,
+     . 4.308,4.308,4.308,4.308,5.753,6.521,
+     . 7.449,8.772,11.014,12.999,16.518,26.772,
+     . 3.265,3.265,3.265,3.265,4.388,5.016,
+     . 5.775,6.868,8.745,10.429,13.457,22.538,
+     . 2.116,2.116,2.116,2.116,2.882,3.330,
+     . 3.876,4.670,6.059,7.327,9.650,16.883/
+c
+      DO i=1, klon
+         taue670(i)=0.0
+         taue865(i)=0.0
+      ENDDO
+c      
+      DO k=1, klev
+      DO i=1, klon
+         if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k)
+         if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k)         
+        zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+        zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG           ! m
+        rh=MIN(RHcl(i,k)*100.,RH_MAX)
+        RH_num = INT( rh/10. + 1.)
+        IF (rh.LT.0.) STOP 'aeropt: RH < 0 not possible'
+        IF (rh.gt.85.) RH_num=10
+        IF (rh.gt.90.) RH_num=11
+        DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+c                
+        inu=1
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+c
+        inu=2
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+cjq
+cjq for aerosol index
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,4) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,4)-
+     .       alpha_aer_sulfate(RH_num,4)) !--m2/g 
+c     
+        taue670(i)=taue670(i)+
+     .       alphasulfate*msulfate(i,k)*zdz*1.e-6
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,5) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,5)-
+     .       alpha_aer_sulfate(RH_num,5)) !--m2/g 
+c
+        taue865(i)=taue865(i)+
+     .         alphasulfate*msulfate(i,k)*zdz*1.e-6
+        
+      ENDDO
+      ENDDO
+c      
+      DO i=1, klon
+        ai(i)=(-log(MAX(taue670(i),0.0001)/
+     .                MAX(taue865(i),0.0001))/log(670./865.)) * 
+     .        taue865(i)
+      ENDDO     
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ajsec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ajsec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ajsec.F	(revision 984)
@@ -0,0 +1,403 @@
+!
+! $Header$
+!
+      SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+c
+      INTEGER limbas(klon), limhau ! les couches a ajuster
+c
+      LOGICAL mixq
+ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+c
+      REAL zh(klon,klev)
+      REAL zho(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+c
+c Initialisation:
+c
+cym
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c------------------------------------- detection des profils a modifier
+      DO k = 1, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zho(i,k) = zh(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = 2, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i).and.k-1>limbas(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas(i)
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas(i)) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+c
+      DO k = 1, limhau
+      DO i = 1, klon
+         d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+! FH : les d_q et d_t sont maintenant calcules de facon a valoir
+! effectivement 0. si on ne fait rien.
+!
+!     IF (limbas.GT.1) THEN
+!     DO k = 1, limbas-1
+!     DO i = 1, klon
+!        d_t(i,k) = 0.0
+!        d_q(i,k) = 0.0
+!     ENDDO
+!     ENDDO
+!     ENDIF
+c
+!     IF (limhau.LT.klev) THEN
+!     DO k = limhau+1, klev
+!     DO i = 1, klon
+!        d_t(i,k) = 0.0
+!        d_q(i,k) = 0.0
+!     ENDDO
+!     ENDDO
+!     ENDIF
+c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+
+      SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+c
+      INTEGER limbas, limhau ! les couches a ajuster
+ccc      PARAMETER (limbas=klev-3, limhau=klev)
+cym      PARAMETER (limbas=1, limhau=klev)
+c
+      LOGICAL mixq
+ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+c
+      REAL zh(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+c
+c Initialisation:
+c
+cym
+      limbas=1
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c------------------------------------- detection des profils a modifier
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = limbas+1, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      IF (limbas.GT.1) THEN
+      DO k = 1, limbas-1
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (limhau.LT.klev) THEN
+      DO k = limhau+1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL d_t(klon,klev)
+c
+      REAL local_h(klon,klev)
+      REAL hm, sm
+      LOGICAL modif(klon), down
+      INTEGER i, l, l1, l2
+c------------------------------------- detection des profils a modifier
+      DO i = 1, klon
+         modif(i)   = .false.
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
+      ENDDO
+      ENDDO
+c
+      DO l = 2, klev
+      DO i = 1, klon
+         IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
+            modif(i) = .true.
+         ELSE
+            modif(i) = modif(i)
+         ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      do 1080 i = 1, klon
+        if (modif(i)) then
+          l2 = 1
+ 8000     continue
+            l2 = l2 + 1
+            if (l2 .gt. klev) goto 8001
+            if (local_h(i, l2) .lt. local_h(i, l2-1)) then
+              l1 = l2 - 1
+              l  = l1
+              sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1))
+              hm = local_h(i, l2)
+ 8020         continue
+                sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+                hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+     .                         * (local_h(i, l) - hm) / sm
+                down = .false.
+                if (l1 .ne. 1) then
+                  if (hm .lt. local_h(i, l1-1)) then
+                    down = .true.
+                  end if
+                end if
+                if (down) then
+                  l1 = l1 - 1
+                  l  = l1
+                else
+                  if ((l2 .eq. klev)) GOTO 8021
+                  IF ((local_h(i, l2+1).ge.hm)) goto 8021
+                  l2 = l2 + 1
+                  l  = l2
+                end if
+              go to 8020
+ 8021         continue
+c------------ nouveau profil : constant (valeur moyenne)
+              do 1100 l = l1, l2
+                local_h(i, l) = hm
+ 1100         continue
+              l2 = l2 + 1
+            end if
+          go to 8000
+ 8001     continue
+        end if
+ 1080 continue
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/albedo.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/albedo.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/albedo.F	(revision 984)
@@ -0,0 +1,191 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE alboc(rjour,rlat,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+c Date: le 16 mars 1995
+c Objet: Calculer l'albedo sur l'ocean
+c Methode: Integrer numeriquement l'albedo pendant une journee
+c
+c Arguments;
+c rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+c rlat (in,R)   : latitude en degre
+c albedo (out,R): albedo obtenu (de 0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "clesphys.h"
+c
+c fmagic -> clesphys.h/.inc
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7)
+      INTEGER npts ! il controle la precision de l'integration
+      PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+c
+      REAL rlat(klon), rjour, albedo(klon)
+      REAL zdist, zlonsun, zpi, zdeclin
+      REAL rmu,alb, srmu, salb, fauxo, aa, bb
+      INTEGER i, k
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      fauxo = (1.47-ACOS(rmu))/.15
+      alb = 0.03+0.630/(1.+fauxo*fauxo)
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         fauxo = (1.47-ACOS(rmu))/.15
+         alb = 0.03+0.630/(1.+fauxo*fauxo)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+  999 CONTINUE
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 1999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+cIM cf. PB  alb = 0.058/(rmu + 0.30)
+c     alb = 0.058/(rmu + 0.30) * 1.5
+      alb = 0.058/(rmu + 0.30) * 1.2
+c     alb = 0.058/(rmu + 0.30) * 1.3
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+cIM cf. PB      alb = 0.058/(rmu + 0.30)
+c        alb = 0.058/(rmu + 0.30) * 1.5
+         alb = 0.058/(rmu + 0.30) * 1.2
+c        alb = 0.058/(rmu + 0.30) * 1.3
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+1999  CONTINUE
+      ENDIF
+      RETURN
+      END
+c=====================================================================
+      SUBROUTINE alboc_cd(rmu0,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940624
+c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+c Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+C on radiation in the atmosphere, 19-28 August 1976, science Press,
+C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+c
+c Arguments
+c rmu0    (in): cosinus de l'angle solaire zenithal
+c albedo (out): albedo de surface de l'ocean
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+      REAL rmu0(klon), albedo(klon)
+c
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7) 
+c
+      REAL fauxo
+      INTEGER i
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      DO i = 1, klon
+c
+         rmu0(i) = MAX(rmu0(i),0.0)
+c
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      DO i = 1, klon
+         rmu0(i) = MAX(rmu0(i),0.0)
+cIM:orig albedo(i) = 0.058/(rmu0(i) + 0.30)
+         albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+      ENDIF
+c
+      RETURN
+      END
+c========================================================================
Index: LMDZ4/tags/LF_20080728/libf/phytherm/albsno.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/albsno.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/albsno.F90	(revision 984)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
+
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN)                  :: klon, knon
+  REAL, INTENT(IN)                     :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+
+! In/Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
+
+! Local variables
+!****************************************************************************************
+  INTEGER                              :: i, nv
+  INTEGER, PARAMETER                   :: nvm = 8 
+  REAL                                 :: as
+  REAL, DIMENSION(klon,nvm)            :: veget
+  REAL, DIMENSION(nvm),SAVE            :: init, decay
+  !$OMP THREADPRIVATE(init, decay)
+
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+!****************************************************************************************
+
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+     alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+     DO i = 1, knon
+        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+     ENDDO
+  ENDDO
+  
+
+! modilation en fonction de l'age de la neige
+  DO i = 1, knon
+     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+     agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+  
+END SUBROUTINE albsno
Index: LMDZ4/tags/LF_20080728/libf/phytherm/atm2geo.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/atm2geo.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/atm2geo.F	(revision 984)
@@ -0,0 +1,60 @@
+!
+! $Header$
+!
+C
+      SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
+      USE dimphy
+      USE mod_phys_lmdz_para
+      IMPLICIT NONE
+      include 'dimensions.h'
+cc
+cc Change wind local atmospheric coordinates to
+cc geocentric
+cc
+cxxx      INCLUDE 'param.h'
+c
+      INTEGER, INTENT (in)              :: im, jm
+      REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn
+      REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
+      REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz
+c
+      REAL, PARAMETER :: rpi = 3.141592653E0
+      REAL, PARAMETER :: rad = rpi / 180.0E0
+c
+      REAL, DIMENSION (im,jm) :: zsinlon, zcoslon
+      REAL, DIMENSION (im,jm) :: zsinlat, zcoslat
+c
+      LOGICAL, SAVE :: linit = .FALSE.
+c$OMP THREADPRIVATE(linit)
+
+cym utilise pour le couple, ne fonctionne que en MPI seul
+c
+cxxx      IF ( .NOT. linit ) THEN 
+          zsinlon = SIN (rad * plon)
+          zcoslon = COS (rad * plon)
+          zsinlat = SIN (rad * plat)
+          zcoslat = COS (rad * plat)
+          linit = .TRUE.
+cxxx      ENDIF 
+c
+      pxx = - zsinlon * pte - zsinlat * zcoslon * ptn
+      pyy =   zcoslon * pte - zsinlat * zsinlon * ptn
+      pzz =   zcoslat * ptn
+
+c
+c Value at North Pole
+      IF (is_north_pole) THEN
+        pxx ( :,  1) = - ptn ( 1, 1)
+        pyy ( :,  1) = - pte ( 1, 1)
+        pzz ( :,  1) = 0.0
+      ENDIF
+c Value at South Pole
+      
+      IF (is_south_pole) THEN
+        pxx ( :, jm) = + ptn ( 1, jm)
+        pyy ( :, jm) = + pte ( 1, jm)
+        pzz ( :, jm) = 0.0
+      ENDIF
+ 
+      RETURN 
+      END SUBROUTINE atm2geo
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calbeta.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calbeta.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calbeta.F90	(revision 984)
@@ -0,0 +1,103 @@
+!
+! $Header$
+!
+SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
+     vbeta,vcal,vdif)
+
+  USE dimphy
+  IMPLICIT none
+!======================================================================
+! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
+! date: 19940414
+!======================================================================
+!
+! Calculer quelques parametres pour appliquer la couche limite
+! ------------------------------------------------------------
+  INCLUDE "indicesol.h"
+  
+! Variables d'entrees
+!****************************************************************************************
+  REAL, INTENT(IN)                   :: dtime
+  INTEGER, INTENT(IN)                :: indice
+  INTEGER, INTENT(IN)                :: knon
+  REAL, DIMENSION(klon), INTENT(IN)  :: snow
+  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
+
+  
+! Variables de sorties
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
+  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
+  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
+
+! Variables locales
+!****************************************************************************************
+  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
+!cc      PARAMETER (tau_gl=86400.0*30.0)
+  REAL, PARAMETER :: mx_eau_sol=150.0
+  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
+  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
+  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
+  
+  INTEGER         :: i
+
+!****************************************************************************************  
+   
+  vbeta(:) = 0.0
+  vcal(:) = 0.0
+  vdif(:) = 0.0
+  
+  IF (indice.EQ.is_oce) THEN
+     DO i = 1, knon
+        vcal(i)   = 0.0
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_sic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 1.0/tau_gl
+!          vdif(i) = calice/tau_gl ! c'etait une erreur
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_ter) THEN
+     DO i = 1, knon
+        vcal(i) = calsol
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_lic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+END SUBROUTINE calbeta
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calcratqs.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calcratqs.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calcratqs.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE calcratqs ( flag_ratqs,
+     I            paprs,pplay,q_seri,d_t_con,d_t_ajs
+     O           ,ratqs,zpt_conv)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL d_t_con(klon,klev)
+      REAL d_t_ajs(klon,klev)
+      REAL ratqs(klon,klev)
+      LOGICAL pt_conv(klon,klev)
+      REAL q_seri(klon,klev)
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+c$OMP THREADPRIVATE(firstcall)
+
+      REAL ratqsmin,ratqsmax,zx,epmax
+      REAL ratqs1,ratqs2,ratqs3,ratqs4
+      REAL ratqsc1,ratqsc2,ratqsc3,ratqsc4
+      INTEGER i,k
+      INTEGER flag_ratqs
+      save ratqsmin,ratqsmax,epmax
+      save ratqs1,ratqs2,ratqs3,ratqs4
+      save ratqsc1,ratqsc2,ratqsc3,ratqsc4
+c$OMP THREADPRIVATE(ratqsmin,ratqsmax,epmax)
+c$OMP THREADPRIVATE(ratqs1,ratqs2,ratqs3,ratqs4)
+c$OMP THREADPRIVATE(ratqsc1,ratqsc2,ratqsc3,ratqsc4)
+      real zpt_conv(klon,klev)
+
+      REAL zx_min
+      PARAMETER (zx_min=1.0)
+      REAL zx_max
+      PARAMETER (zx_max=0.1)
+
+	zpt_conv=0.
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c
+      if (flag_ratqs.eq.0) then
+
+         ratqsmax=0.01
+         ratqsmin=0.3
+
+         if (firstcall) print*,'RATQS ANCIEN '
+         do k=1,klev
+         do i=1,klon
+            zx = pplay(i,k)/paprs(i,1)
+            zx = (zx_max-zx)/(zx_max-zx_min)
+            zx = MIN(MAX(zx,0.0),1.0)
+            zx = zx * zx * zx
+            ratqs(i,k)= zx * (ratqsmax-ratqsmin) + ratqsmin
+         enddo
+         enddo
+
+      else
+
+c  On aplique un ratqs "interactif" a toutes les mailles affectees
+c  par la convection ou se trouvant "sous" une maille affectee.
+         do i=1,klon
+            pt_conv(i,klev)=.false.
+         enddo
+         do k=klev-1,1,-1
+            do i=1,klon
+               pt_conv(i,k)=pt_conv(i,k+1).or.
+     s               (abs(d_t_con(i,k))+abs(d_t_ajs(i,k))).gt.1.e-8
+               if(pt_conv(i,k)) then
+                  zpt_conv(i,k)=1.
+               else
+                  zpt_conv(i,k)=0.
+               endif
+            enddo
+         enddo
+
+         if (flag_ratqs.eq.1) then
+
+            ratqsmin=0.4
+            ratqsmax=0.99
+            if (firstcall) print*,'RATQS INTERACTIF '
+            do k=1,klev
+                do i=1,klon
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=0.01
+     s                +1.5*0.25*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                      ratqs(i,k)=max(ratqs(i,k),0.1)
+                   else
+                      ratqs(i,k)=0.01+(ratqsmin-0.01)*
+     s             min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.)
+                   endif
+                enddo
+            enddo
+         else if (flag_ratqs.eq.2) then
+            do k=1,klev
+                do i=1,klon
+                   ratqs(i,k)=0.001+
+     s             (q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                   else
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmin)
+                   endif
+                enddo
+            enddo
+         else
+            do k=1,klev
+               do i=1,klon
+                  if (pplay(i,k).ge.95000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc1
+                     else
+                        ratqs(i,k)=ratqs1
+                     endif
+                  else if (pplay(i,k).ge.75000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc2
+                     else
+                        ratqs(i,k)=ratqs2
+                     endif
+                  else if (pplay(i,k).ge.50000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc3
+                     else
+                        ratqs(i,k)=ratqs3
+                     endif
+                  else
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc4
+                     else
+                        ratqs(i,k)=ratqs4
+                     endif
+                  endif
+               enddo
+            enddo
+         endif
+
+      endif
+
+      firstcall=.false.
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calcul_REGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calcul_REGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calcul_REGDYN.h	(revision 984)
@@ -0,0 +1,22 @@
+c
+c $Header$
+c
+c calculs statistiques distribution nuage ftion du regime dynamique 
+c
+c Ce calcul doit etre fait a partir de valeurs mensuelles ??
+      CALL histo_o500_pctau(nbregdyn,pct_ocean,o500,fq_isccp,
+     &histoW,nhistoW)
+c
+c nhistoWt = somme de toutes les nhistoW
+      DO nreg=1, nbregdyn
+       DO k = 1, kmaxm1
+        DO l = 1, lmaxm1
+         DO iw = 1, iwmax
+          nhistoWt(k,l,iw,nreg)=nhistoWt(k,l,iw,nreg)+
+     &    nhistoW(k,l,iw,nreg)
+         ENDDO
+        ENDDO
+       ENDDO
+      ENDDO
+c
+cIM 190504 END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calcul_STDlev.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calcul_STDlev.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calcul_STDlev.h	(revision 984)
@@ -0,0 +1,324 @@
+c
+c $Header$
+c
+c
+cIM on initialise les champs en debut du jour ou du mois 
+c
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,tsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,usumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,phisumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,qsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,rhsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,uvsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vqsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vTsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wqsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,vphisumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,wTsumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,u2sumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,v2sumSTD)
+        CALL ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $                    tnondef,T2sumSTD)
+c
+cIM on interpole sur les niveaux STD de pression a chaque pas de temps de la physique
+c
+       DO k=1, nlevSTD
+c
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .              t_seri,tlevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             u_seri,ulevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             v_seri,vlevSTD(:,k))
+c
+        DO l=1, klev
+        DO i=1, klon
+         zx_tmp_fi3d(i,l)=paprs(i,l)
+        ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,zx_tmp_fi3d,rlevSTD(k),
+     .             omega,wlevSTD(:,k))
+c
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zphi/RG,philevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             qx(:,:,ivap),qlevSTD(:,k))
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_rh*100.,rhlevSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,uvSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*q_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vqSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vTSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*qx(i,l,ivap)
+         ENDDO !i 
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,wqSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*zphi(i,l)/RG
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,vphiSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,wTSTD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*u_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,u2STD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,v2STD(:,k))
+c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=t_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel(klon,klev,.true.,pplay,rlevSTD(k),
+     .             zx_tmp_fi3d,T2STD(:,k))
+c
+       ENDDO !k=1,nlevSTD
+c
+cIM on somme les valeurs definies a chaque pas de temps de la physique ou 
+cIM toutes les 6 heures
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.TRUE.
+       CALL undefSTD(nlevSTD,itap,tlevSTD,
+     $               dtime,ecrit_hf,
+     $               oknondef,tnondef,tsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,ulevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,usumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,philevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,phisumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,qlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,qsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,rhlevSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,rhsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,uvSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,uvsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vqSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vqsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vTSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vTsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wqSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wqsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,vphiSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,vphisumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,wTSTD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,wTsumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,u2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,u2sumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,v2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,v2sumSTD)
+c
+       oknondef(1:klon,1:nlevSTD,1:nout)=.FALSE.
+       CALL undefSTD(nlevSTD,itap,T2STD,
+     $           dtime,ecrit_hf,
+     $               oknondef,tnondef,T2sumSTD)
+c
+cIM on moyenne a la fin du jour ou du mois 
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,tsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,usumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,phisumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,qsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,rhsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,uvsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vqsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vTsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wqsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,vphisumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,wTsumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,u2sumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,v2sumSTD)
+c
+       CALL moy_undefSTD(nlevSTD,itap,
+     $      dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $                   tnondef,T2sumSTD)
+c
+cIM interpolation a chaque pas de temps du SWup(clr) et SWdn(clr) a 200 hPa
+c
+      CALL plevel(klon,klevp1,.true.,paprs,20000.,
+     $     swdn0,SWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swdn,SWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swup0,SWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     swup,SWup200)
+c
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwdn0,LWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwdn,LWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwup0,LWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,
+     $     lwup,LWup200)
+c
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calcul_divers.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calcul_divers.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calcul_divers.h	(revision 984)
@@ -0,0 +1,29 @@
+c
+c $Header$
+c
+c
+c initialisations diverses au "debut" du mois
+c
+      IF(MOD(itap,INT(ecrit_mth)).EQ.1) THEN
+         DO i=1, klon
+          nday_rain(i)=0.
+         ENDDO !i
+c
+c surface terre
+       DO i=1, klon
+         IF(pctsrf_new(i,is_ter).GT.0.) THEN
+            paire_ter(i)=airephy(i)*pctsrf_new(i,is_ter)
+         ENDIF 
+       ENDDO
+c
+      ENDIF !MOD(itap,INT(ecrit_mth)).EQ.1
+c
+      IF(MOD(itap,INT(ecrit_day)).EQ.0) THEN
+c
+cIM calcul total_rain, nday_rain
+c
+       DO i = 1, klon
+        total_rain(i)=rain_fall(i)+snow_fall(i)  
+        IF(total_rain(i).GT.0.) nday_rain(i)=nday_rain(i)+1.
+       ENDDO
+      ENDIF !itap.EQ.ecrit_mth
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calcul_fluxs_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calcul_fluxs_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calcul_fluxs_mod.F90	(revision 984)
@@ -0,0 +1,246 @@
+!
+! $Header$
+!
+MODULE calcul_fluxs_mod
+
+
+CONTAINS
+  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
+       tsurf, p1lay, cal, beta, coef1lay, ps, &
+       precip_rain, precip_snow, snow, qsurf, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    USE dimphy, ONLY : klon
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   qsurf        humidite de l'air au dessus du sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon, nisurf
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
+    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
+
+! Parametres entree-sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
+
+! Parametres sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
+
+! Variables locales
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
+    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
+    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+    REAL, DIMENSION(klon)                :: zx_sl, zx_k1
+    REAL, DIMENSION(klon)                :: d_ts
+    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+    REAL                                 :: qsat_new, q1_new
+    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
+    REAL, PARAMETER                      :: max_eau_sol = 150.0
+    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
+    LOGICAL                              :: fonte_neige
+    LOGICAL, SAVE                        :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! End definition
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
+    
+    IF (check) THEN
+       WRITE(*,*)' radsol (min, max)', &
+            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
+       CALL flush(6)
+    ENDIF
+  
+! Traitement neige et humidite du sol
+!****************************************************************************************
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!****************************************************************************************
+    evap = 0.
+    fluxsens=0.
+    fluxlat=0.
+    dflux_s = 0.
+    dflux_l = 0.	
+!
+! zx_qs = qsat en kg/kg
+!****************************************************************************************
+    DO i = 1, knon
+       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+       IF (thermcep) THEN
+          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+          zx_qs=MIN(0.5,zx_qs)
+          zcor=1./(1.-retv*zx_qs)
+          zx_qs=zx_qs*zcor
+          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+               /RLVTT / zx_pkh(i)
+       ELSE
+          IF (tsurf(i).LT.t_coup) THEN
+             zx_qs = qsats(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ELSE
+             zx_qs = qsatl(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ENDIF
+       ENDIF
+       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+       zx_qsat(i) = zx_qs
+       zx_coef(i) = coef1lay(i) * &
+            (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
+            p1lay(i)/(RD*t1lay(i))
+       
+    ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!****************************************************************************************
+
+    DO i = 1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+       zx_k1(i) = zx_coef(i)
+    ENDDO
+    
+
+    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)
+       zx_nq(i) = beta(i) * zx_k1(i) * (-1. * 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)
+     
+! Tsurface
+       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+            + dif_grnd(i) * t_grnd * dtime)/ &
+            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+            + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+       d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+       fluxlat(i) = - evap(i) * zx_sl(i)
+       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+       
+! Derives des flux dF/dTs (W m-2 K-1):
+       dflux_s(i) = zx_nh(i)
+       dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+! Nouvelle valeure de l'humidite au dessus du sol
+       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
+       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+    ENDDO
+!
+!****************************************************************************************
+!
+  END SUBROUTINE calcul_fluxs
+
+END MODULE calcul_fluxs_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calcul_simulISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calcul_simulISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calcul_simulISCCP.h	(revision 984)
@@ -0,0 +1,168 @@
+c
+c $Header$
+c
+c on appelle le simulateur ISCCP toutes les 3h
+c et on fait des sorties 1 fois par jour 
+c
+c ATTENTION : le temps de calcul peut augmenter considerablement !
+c =============================================================== c
+      DO n=1, napisccp
+c
+      nbapp_isccp=30 !appel toutes les 15h
+cIM 170107      isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique
+      freqin_pdt(n)=ifreq_isccp(n)
+c
+cIM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee
+c
+      DO i=1, klon
+       sunlit(i)=1 
+       IF(rmu0(i).EQ.0.) sunlit(i)=0
+       nbsunlit(1,i,n)=FLOAT(sunlit(i))
+      ENDDO
+c
+cIM calcul tau, emissivite nuages convectifs
+c
+      convfra(:,:)=rnebcon(:,:)
+      convliq(:,:)=rnebcon(:,:)*clwcon(:,:)
+c
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, convliq, convfra, dtau_c, dem_c,
+     .            cldh_c, cldl_c, cldm_c, cldt_c, cldq_c,
+     .            flwp_c, fiwp_c, flwc_c, fiwc_c,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+c
+cIM calcul tau, emissivite nuages startiformes
+c
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, dtau_s, dem_s,
+     .            cldh_s, cldl_s, cldm_s, cldt_s, cldq_s,
+     .            flwp_s, fiwp_s, flwc_s, fiwc_s,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+c
+      cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+c
+cIM inversion des niveaux de pression ==> de haut en bas
+c
+      CALL haut2bas(klon, klev, pplay, pfull)
+      CALL haut2bas(klon, klev, q_seri, qv)
+      CALL haut2bas(klon, klev, cldtot, cc)
+      CALL haut2bas(klon, klev, rnebcon, conv)
+      CALL haut2bas(klon, klev, dtau_s, dtau_sH2B)
+      CALL haut2bas(klon, klev, dtau_c, dtau_cH2B)
+      CALL haut2bas(klon, klev, t_seri, at)
+      CALL haut2bas(klon, klev, dem_s, dem_sH2B)
+      CALL haut2bas(klon, klev, dem_c, dem_cH2B)
+      CALL haut2bas(klon, klevp1, paprs, phalf)
+c
+cIM lecture invtau, tautab des fichiers formattes
+c
+      IF (debut) THEN
+c$OMP MASTER
+c     open(99,file='tautab.bin',access='sequential',
+c    $     form='unformatted',status='old')
+c     read(99) tautab_omp
+c
+      open(99,file='tautab.formatted', FORM='FORMATTED')
+      read(99,'(f30.20)') tautab_omp
+      close(99)
+c
+      open(99,file='invtau.formatted',form='FORMATTED')
+      read(99,'(i10)') invtau_omp
+      close(99)
+c$OMP END MASTER
+c$OMP BARRIER
+      tautab=tautab_omp
+      invtau=invtau_omp
+c
+      ENDIF !debut
+c
+cIM: initialisation de seed
+c
+        DO i=1, klon
+c
+         aa=ABS(paprs(i,2)-NINT(paprs(i,2)))
+         seed_re(i,n)=1000.*aa+1.
+         seed(i,n)=NINT(seed_re(i,n))
+c
+         IF(seed(i,n).LT.50) THEN
+c          print*,'seed<50 avant i seed itap paprs',i,
+c    .     seed(i,n),itap,paprs(i,2)
+           seed(i,n)=50+seed(i,n)+i+itap
+           seed_old(i,n)=seed(i,n)
+c
+           IF(itap.GT.1) then
+            IF(seed(i,n).EQ.seed_old(i,n)) THEN
+             seed(i,n)=seed(i,n)+10
+             seed_old(i,n)=seed(i,n)
+            ENDIF
+           ENDIF
+c
+c          print*,'seed<50 apres i seed itap paprs',i,
+c    .     seed(i,n),itap,paprs(i,2)
+c
+          ELSE IF(seed(i,n).EQ.0) THEN
+           print*,'seed=0 i paprs aa seed_re',
+     .     i,paprs(i,2),aa,seed_re(i,n)
+           STOP
+          ELSE IF(seed(i,n).LT.0) THEN
+           print*,'seed < 0, i seed itap paprs',i,
+     .     seed(i,n),itap,paprs(i,2)
+           STOP
+          ENDIF
+c
+        ENDDO
+c     
+cIM: pas de debug, debugcol
+      debug=0
+      debugcol=0
+c
+cIM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa)
+c
+        DO k=1, klevm1
+        kp1=k+1
+c       PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1)
+        if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN
+         DO i=1, klon
+          o500(i)=omega(i,k)*RDAY/100.
+c         if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1)
+         ENDDO
+         GOTO 1000
+        endif 
+1000  continue
+      ENDDO
+c
+cIM recalcule les nuages vus par satellite, via le simulateur ISCCP
+c
+      CALL ISCCP_CLOUD_TYPES(
+     &     debug,
+     &     debugcol,
+     &     klon,
+     &     sunlit,
+     &     klev,
+     &     ncol(n),
+     &     seed(:,n),
+     &     pfull,
+     &     phalf,
+     &     qv, cc, conv, dtau_sH2B, dtau_cH2B,
+     &     top_height,
+     &     overlap,
+     &     tautab,
+     &     invtau,
+     &     ztsol,
+     &     emsfc_lw,
+     &     at, dem_sH2B, dem_cH2B,
+     &     fq_isccp(:,:,:,n),
+     &     totalcldarea(:,n),
+     &     meanptop(:,n),
+     &     meantaucld(:,n),
+     &     boxtau(:,:,n),
+     &     boxptop(:,:,n))
+c
+      ENDDO !n=1, napisccp
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/calltherm.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/calltherm.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/calltherm.F90	(revision 984)
@@ -0,0 +1,291 @@
+!
+! $Header$
+!
+      subroutine calltherm(dtime  &
+     &      ,pplay,paprs,pphi,weak_inversion  &
+     &      ,u_seri,v_seri,t_seri,q_seri,zqsat,debut  &
+     &      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs  &
+     &      ,fm_therm,entr_therm,zqasc,clwcon0,lmax,ratqscth,  &
+     &       ratqsdiff,zqsatth)
+
+      implicit none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "thermcell.h"
+
+!  A inclure eventuellement dans les fichiers de configuration
+      data r_aspect_thermals,l_mix_thermals,tho_thermals/2.,30.,0./
+      data w2di_thermals/0/
+
+      REAL dtime
+      LOGICAL debut
+      REAL u_seri(klon,klev),v_seri(klon,klev)
+      REAL t_seri(klon,klev),q_seri(klon,klev),qmemoire(klon,klev)
+      REAL weak_inversion(klon)
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      real zlev(klon,klev+1) 
+
+!FH Update Thermiques
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_u_ajs(klon,klev),d_v_ajs(klon,klev)
+      real fm_therm(klon,klev+1),entr_therm(klon,klev)
+
+!********************************************************
+!     declarations
+      real fmc_therm(klon,klev+1),zqasc(klon,klev)
+      real zqla(klon,klev)
+      real wmax_sec(klon)
+      real zmax_sec(klon)
+      real f_sec(klon)
+      real detrc_therm(klon,klev)
+      save fmc_therm, detrc_therm
+      real clwcon0(klon,klev)
+      real zqsat(klon,klev)
+      real zw_sec(klon,klev+1)
+      integer lmix_sec(klon)
+      integer lmax(klon)
+      real ratqscth(klon,klev)
+      real ratqsdiff(klon,klev)
+      real zqsatth(klon,klev)  
+!********************************************************
+
+
+! variables locales
+      REAL d_t_the(klon,klev), d_q_the(klon,klev)
+      REAL d_u_the(klon,klev),d_v_the(klon,klev)
+!
+      real zfm_therm(klon,klev+1),zentr_therm(klon,klev),zdt
+      save zentr_therm,zfm_therm
+
+      integer i,k
+
+!********************************************************
+
+!  Modele du thermique
+!  ===================
+!         print*,'thermiques: WARNING on passe t au lieu de t_seri'
+
+
+         fm_therm(:,:)=0.
+         entr_therm(:,:)=0.
+       print*,'thermV4 nsplit: ',nsplit_thermals,' weak_inversion'
+
+
+!   tests sur les valeurs negatives de l'eau
+         do k=1,klev
+            do i=1,klon
+               if (.not.q_seri(i,k).ge.0.) then
+                   print*,'WARN eau<0 avant therm i=',i,'  k=',k  &
+     &         ,' dq,q',d_q_the(i,k),q_seri(i,k)
+                  q_seri(i,k)=1.e-15
+               endif
+            enddo
+         enddo
+
+
+         zdt=dtime/float(nsplit_thermals)
+         do isplit=1,nsplit_thermals
+
+          if (iflag_thermals.eq.1) then
+            CALL thermcell_2002(klon,klev,zdt   &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,30.,w2di_thermals  &
+     &      ,tho_thermals,3)
+          else if (iflag_thermals.eq.2) then
+            CALL thermcell_sec(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,zlev  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,30.,w2di_thermals  &
+     &      ,tho_thermals,3)
+          else if (iflag_thermals.eq.3) then
+            CALL thermcell(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tho_thermals,3)
+          else if (iflag_thermals.eq.10) then
+            CALL thermcell_eau(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tho_thermals,3)
+          else if (iflag_thermals.eq.11) then
+            stop'cas non prevu dans calltherm'
+!           CALL thermcell_pluie(klon,klev,zdt  &
+!   &      ,pplay,paprs,pphi,zlev  &
+!    &      ,u_seri,v_seri,t_seri,q_seri  &
+!    &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+!    &      ,zfm_therm,zentr_therm,zqla  &
+!    &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+!    &      ,tho_thermals,3)
+          else if (iflag_thermals.eq.12) then
+            CALL calcul_sec(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,zlev  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,zmax_sec,wmax_sec,zw_sec,lmix_sec  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tho_thermals)
+!            CALL calcul_sec_entr(klon,klev,zdt
+!     s      ,pplay,paprs,pphi,zlev,debut
+!     s      ,u_seri,v_seri,t_seri,q_seri                
+!     s      ,zmax_sec,wmax_sec,zw_sec,lmix_sec
+!     s      ,r_aspect_thermals,l_mix_thermals,w2di_thermals
+!     s      ,tho_thermals,3)
+!           CALL thermcell_pluie_detr(klon,klev,zdt  &
+!    &      ,pplay,paprs,pphi,zlev,debut  &
+!    &      ,u_seri,v_seri,t_seri,q_seri  &
+!    &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+!    &      ,zfm_therm,zentr_therm,zqla,lmax  &
+!    &      ,zmax_sec,wmax_sec,zw_sec,lmix_sec  &
+!    &      ,ratqscth,ratqsdiff,zqsatth  &
+!    &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+!    &      ,tho_thermals)
+          else if (iflag_thermals.ge.13) then
+            CALL thermcell_main(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,debut  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm,zqla,lmax  &
+     &      ,ratqscth,ratqsdiff,zqsatth  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tho_thermals)
+         endif
+
+
+      DO i=1,klon
+      DO k=1,klev
+            IF(iflag_thermals.lt.14.or.weak_inversion(i).gt.0.5) THEN
+
+!  transformation de la derivee en tendance
+            d_t_the(i,k)=d_t_the(i,k)*dtime/float(nsplit_thermals)
+            d_u_the(i,k)=d_u_the(i,k)*dtime/float(nsplit_thermals)
+            d_v_the(i,k)=d_v_the(i,k)*dtime/float(nsplit_thermals)
+            d_q_the(i,k)=d_q_the(i,k)*dtime/float(nsplit_thermals)
+            fm_therm(i,k)=fm_therm(i,k)  &
+     &      +zfm_therm(i,k)/float(nsplit_thermals)
+            entr_therm(i,k)=entr_therm(i,k)  &
+     &       +zentr_therm(i,k)/float(nsplit_thermals)
+            fm_therm(:,klev+1)=0.
+
+
+
+!  accumulation de la tendance
+            d_t_ajs(i,k)=d_t_ajs(i,k)+d_t_the(i,k)
+            d_u_ajs(i,k)=d_u_ajs(i,k)+d_u_the(i,k)
+            d_v_ajs(i,k)=d_v_ajs(i,k)+d_v_the(i,k)
+            d_q_ajs(i,k)=d_q_ajs(i,k)+d_q_the(i,k)
+
+!  incrementation des variables meteo
+            t_seri(i,k) = t_seri(i,k) + d_t_the(i,k)
+            u_seri(i,k) = u_seri(i,k) + d_u_the(i,k)
+            v_seri(i,k) = v_seri(i,k) + d_v_the(i,k)
+            qmemoire(i,k)=q_seri(i,k)
+            q_seri(i,k) = q_seri(i,k) + d_q_the(i,k)
+           ENDIF
+       ENDDO
+       ENDDO
+
+!   tests sur les valeurs negatives de l'eau
+            DO k = 1, klev
+            DO i = 1, klon
+               if (.not.q_seri(i,k).ge.0.) then
+                   print*,'WARN eau<0 apres therm i=',i,'  k=',k  &
+     &         ,' dq,q',d_q_the(i,k),q_seri(i,k),  &
+     &         'fm=',zfm_therm(i,k),'entr=',entr_therm(i,k)
+                  q_seri(i,k)=1.e-15
+!       stop
+               endif
+            ENDDO
+            ENDDO
+! tests sur les valeurs de la temperature
+            DO k = 1, klev
+            DO i = 1, klon
+               if ((t_seri(i,k).lt.50.) .or.  &
+     &              (t_seri(i,k).gt.370.)) then
+                  print*,'WARN temp apres therm i=',i,'  k=',k  &
+     &         ,' t_seri',t_seri(i,k)
+!              CALL abort
+               endif
+            ENDDO
+            ENDDO
+
+         enddo ! isplit
+
+!
+!***************************************************************
+!     calcul du flux ascencant conservatif
+!            print*,'<<<<calcul flux ascendant conservatif'
+
+      fmc_therm=0.
+               do k=1,klev
+            do i=1,klon
+                  if (entr_therm(i,k).gt.0.) then
+                     fmc_therm(i,k+1)=fmc_therm(i,k)+entr_therm(i,k)
+                  else
+                     fmc_therm(i,k+1)=fmc_therm(i,k)
+                  endif
+                  detrc_therm(i,k)=(fmc_therm(i,k+1)-fm_therm(i,k+1))  &
+     &                 -(fmc_therm(i,k)-fm_therm(i,k))
+               enddo
+            enddo
+      
+     
+!****************************************************************
+!     calcul de l'humidite dans l'ascendance
+!      print*,'<<<<calcul de lhumidite dans thermique'
+!CR:on ne le calcule que pour le cas sec
+      if (iflag_thermals.le.11) then      
+      do i=1,klon
+         zqasc(i,1)=q_seri(i,1)
+         do k=2,klev
+            if (fmc_therm(i,k+1).gt.1.e-6) then
+               zqasc(i,k)=(fmc_therm(i,k)*zqasc(i,k-1)  &
+     &              +entr_therm(i,k)*q_seri(i,k))/fmc_therm(i,k+1)
+!CR:test on asseche le thermique
+!               zqasc(i,k)=zqasc(i,k)/2.
+!            else
+!               zqasc(i,k)=q_seri(i,k)
+            endif
+         enddo
+       enddo
+      
+
+!     calcul de l'eau condensee dans l'ascendance
+!             print*,'<<<<calcul de leau condensee dans thermique'
+             do i=1,klon
+                do k=1,klev
+                   clwcon0(i,k)=zqasc(i,k)-zqsat(i,k)
+                   if (clwcon0(i,k).lt.0. .or.   &
+     &             (fm_therm(i,k+1)+detrc_therm(i,k)).lt.1.e-6) then
+                      clwcon0(i,k)=0.
+                   endif
+                enddo
+             enddo
+       else
+              do i=1,klon
+                do k=1,klev
+                   clwcon0(i,k)=zqla(i,k)  
+                   if (clwcon0(i,k).lt.0. .or.   &
+     &             (fm_therm(i,k+1)+detrc_therm(i,k)).lt.1.e-6) then
+                   clwcon0(i,k)=0. 
+                   endif
+                enddo
+             enddo
+       endif
+!*******************************************************************    
+
+
+      return
+
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/chem.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/chem.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/chem.h	(revision 984)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+      INTEGER idms, iso2, iso4, ih2s, idmso, imsa, ih2o2
+      PARAMETER (idms=1, iso2=2, iso4=3)
+      PARAMETER (ih2s=4, idmso=5, imsa=6, ih2o2=7)
+
+      REAL n_avogadro, masse_s, masse_so4, rho_water, rho_ice
+      PARAMETER (n_avogadro=6.02E23)                  !--molec mol-1
+      PARAMETER (masse_s=32.0)                        !--g mol-1
+      PARAMETER (masse_so4=96.0)                      !--g mol-1
+      PARAMETER (rho_water=1000.0)                    !--kg m-3
+      PARAMETER (rho_ice=500.0)                       !--kg m-3
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/clcdrag.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/clcdrag.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/clcdrag.F90	(revision 984)
@@ -0,0 +1,108 @@
+!
+! $Header$
+!
+      SUBROUTINE clcdrag(klon, knon, nsrf, zxli, &
+                         u, v, t, q, zgeop, &
+                         ts, qsurf, rugos, &
+                         pcfm, pcfh)
+      IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh).   
+!
+! ================================================================= c
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- calcul des cdrags selon Laurent Li
+! u-------input-R- vent zonal au 1er niveau du modele
+! v-------input-R- vent meridien au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+!
+! pcfm---output-R- cdrag pour le moment 
+! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, intent(in), dimension(klon) :: u, v, t, q, zgeop
+      REAL, intent(in), dimension(klon) :: ts, qsurf
+      REAL, intent(in), dimension(klon) :: rugos
+      REAL, intent(out), dimension(klon) :: pcfm, pcfh
+! ================================================================= c
+!
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "indicesol.h"
+!
+! Quelques constantes et options:
+!!$PB      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+      REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+      INTEGER :: i
+      REAL :: zdu2, ztsolv, ztvd, zscf
+      REAL :: zucf, zcr
+      REAL :: friv, frih
+      REAL, dimension(klon) :: zcfm1, zcfm2
+      REAL, dimension(klon) :: zcfh1, zcfh2
+      REAL, dimension(klon) :: zcdn
+      REAL, dimension(klon) :: zri
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+! ================================================================= c
+!
+! Calculer le frottement au sol (Cdrag)
+!
+      DO i = 1, knon
+        zdu2 = max(cepdu2,u(i)**2+v(i)**2)
+        ztsolv = ts(i) * (1.0+RETV*qsurf(i))
+        ztvd = (t(i)+zgeop(i)/RCPD/(1.+RVTMP2*q(i))) &
+             *(1.+RETV*q(i))
+        zri(i) = zgeop(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+        zcdn(i) = (ckap/log(1.+zgeop(i)/(RG*rugos(i))))**2
+!
+!!$        IF (zri(i) .ge. 0.) THEN      ! situation stable
+        IF (zri(i) .gt. 0.) THEN      ! situation stable
+          zri(i) = min(20.,zri(i))
+          IF (.NOT.zxli) THEN
+            zscf = SQRT(1.+cd*ABS(zri(i)))
+            FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1)
+            zcfm1(i) = zcdn(i) * FRIV
+            FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 )
+!!$  PB          zcfh1(i) = zcdn(i) * FRIH
+            zcfh1(i) = 0.8 * zcdn(i) * FRIH
+            pcfm(i) = zcfm1(i)
+            pcfh(i) = zcfh1(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fsta(zri(i))
+            pcfh(i) = zcdn(i)* fsta(zri(i))
+          ENDIF
+        ELSE                          ! situation instable
+          IF (.NOT.zxli) THEN
+            zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
+                 *(1.0+zgeop(i)/(RG*rugos(i)))))
+            zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1)
+!!$PB            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            zcfh2(i) = 0.8 * zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            pcfm(i) = zcfm2(i)
+            pcfh(i) = zcfh2(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fins(zri(i))
+            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) =0.8* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
+        ENDIF
+      END DO
+      RETURN
+      END SUBROUTINE clcdrag
Index: LMDZ4/tags/LF_20080728/libf/phytherm/clesphys.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/clesphys.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/clesphys.h	(revision 984)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!..include cles_phys.h
+!
+       LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf 
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
+       REAL co2_ppm, solaire
+       REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12  
+       REAL*8 CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt
+
+!OM ---> correction du bilan d'eau global
+!OM Correction sur precip KE
+       REAL cvl_corr
+!OM Fonte calotte dans bilan eau
+       LOGICAL ok_lic_melt
+
+!IM simulateur ISCCP 
+       INTEGER top_height, overlap
+!IM seuils cdrm, cdrh
+       REAL cdmmax, cdhmax
+!IM param. stabilite s/ terres et en dehors
+       REAL ksta, ksta_ter
+!IM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH
+       LOGICAL ok_kzmin
+!IM fmagic : parametre pour regler l albedo sur ocean
+       REAL fmagic
+!IM lev_histhf  : niveau sorties 6h
+!IM lev_histday : niveau sorties journalieres
+!IM lev_histmth : niveau sorties mensuelles
+       INTEGER lev_histhf, lev_histday, lev_histmth
+       CHARACTER*4 type_run
+       LOGICAL ok_isccp, ok_regdyn
+       REAL lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+       REAL ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day
+       REAL ecrit_mth, ecrit_tra, ecrit_reg 
+       REAL freq_ISCCP, ecrit_ISCCP
+       INTEGER :: ip_ebil_phy
+       LOGICAL ok_slab_sicOBS
+
+       COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
+     &     ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con       &
+     &     , co2_ppm, solaire, RCO2, RCH4, RN2O, RCFC11, RCFC12         &
+     &     , CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt                     &
+     &     , top_height, overlap, cdmmax, cdhmax, ksta, ksta_ter        &
+     &     , ok_kzmin, fmagic, lev_histhf, lev_histday, lev_histmth     &
+     &     , type_run, ok_isccp, ok_regdyn                              &
+     &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
+     &     , ecrit_ins, ecrit_hf, ecrit_hf2mth, ecrit_day               &
+     &     , ecrit_mth, ecrit_tra, ecrit_reg                            &
+     &     , freq_ISCCP, ecrit_ISCCP, ip_ebil_phy                       &
+     &     , ok_slab_sicOBS, ok_lic_melt, cvl_corr
+     
+!$OMP THREADPRIVATE(/clesphys/)
+ 
Index: LMDZ4/tags/LF_20080728/libf/phytherm/clift.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/clift.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/clift.F	(revision 984)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+        SUBROUTINE CLIFT (P,T,RR,RS,PLCL,DPLCLDT,DPLCLDQ)
+C***************************************************************
+C*                                                             *
+C* CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
+C*         DERIVATIVES RELATIVE TO T AND R                     *
+C*   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
+C*                                                             *
+C* written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
+C* modified by :                                               *
+C***************************************************************
+C*
+C*Arguments :
+C*
+C* Input :  P = pressure of level from wich lifting is performed
+C*          T = temperature of level P
+C*          RR = vapour mixing ratio at level P
+C*          RS = vapour saturation mixing ratio at level P
+C*
+C* Output : PLCL = lifting condensation level
+C*          DPLCLDT = derivative of PLCL relative to T
+C*          DPLCLDQ = derivative of PLCL relative to R
+C*
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c      CPD = 3.5 * RD
+c      CPV = 4.0 * RV
+c      CL = 4218.0
+c      CI=2090.0
+c      CPVMCL=CL-CPV
+c      CLMCI=CL-CI
+c      EPS=RD/RV
+c      ALV0=2.5008E+06
+c      ALF0=3.34E+05
+c
+c on utilise les constantes thermo du Centre Europeen: (sb)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+c
+c      Bolton formula coefficients :
+      A = 1669.0
+      B = 122.0
+c
+      RH=RR/RS
+      CHI=T/(A-B*RH-T)
+      PLCL=P*(RH**CHI)
+c
+      ALV = ALV0 - CPVMCL*(T-273.15)
+c
+c -- sb: correction:
+c       DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
+      DPLCLDQ = PLCL*CHI*( 1./RR + B*CHI/T/RS*ALOG(RH) )
+c sb --
+c
+      DPLCLDT = PLCL*CHI*((A-B*RH*(1.+ALV/RV/T))/T**2*CHI*ALOG(RH)
+     $                    - ALV/RV/T**2 )
+c
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/climb_hq_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/climb_hq_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/climb_hq_mod.F90	(revision 984)
@@ -0,0 +1,366 @@
+MODULE climb_hq_mod
+!
+! Module to solve the verctical diffusion of "q" and "H"; 
+! specific humidity and potential energi.
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_hq_down, climb_hq_up
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
+  !$OMP THREADPRIVATE(gamaq,gamah)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
+  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
+  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
+  !$OMP THREADPRIVATE(Kcoefhq)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
+       delp, temp, q, dtime, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+    INCLUDE "YOMCST.h"
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqAcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: petBcoef
+    REAL, DIMENSION(klon), INTENT(OUT)       :: peqBcoef
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: dels, local_H
+    REAL, DIMENSION(klon)                    :: psref, delz, pkh
+    INTEGER                                  :: k, i, ierr
+
+! Include
+!****************************************************************************************
+  INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation
+!   
+!****************************************************************************************
+
+    ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
+    
+    ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
+    
+    ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
+    
+    ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
+    
+    ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
+    
+    ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
+    
+    ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
+    IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
+       
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefhq(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefhq(i,k) = &
+               coefhq(i,k)*RG /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefhq(i,k) = Kcoefhq(i,k) * dtime*RG
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of start value for gama
+    IF (iflag_pbl == 1) THEN
+       gamaq(:,:) = 0.0
+       gamah(:,:) = -1.0e-03
+       gamah(:,2) = -2.5e-03
+    ELSE
+       gamaq(:,:) = 0.0
+       gamah(:,:) = 0.0
+    ENDIF
+    
+!   calculation of gama
+    DO k = 2, klev
+       DO i = 1, knon
+          delz(i)  = RD * (temp(i,k-1)+temp(i,k)) / & 
+               2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+          pkh(i) = (psref(i)/paprs(i,k))**RKAPPA
+          
+          gamaq(i,k) = gamaq(i,k) * delz(i)    
+          gamah(i,k) = gamah(i,k) * delz(i) * RCPD * pkh(i)
+       ENDDO
+    ENDDO
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific humidity, q
+!
+!****************************************************************************************
+    dels(:,:) = delp(:,:)
+    
+    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), dels(:,:), q(:,:), &
+         Ccoef_Q(:,:), Dcoef_Q(:,:))
+
+!****************************************************************************************
+! 5)
+! Calculte the coefficients C and D for potentiel entalpie, H 
+!
+!****************************************************************************************
+    dels(:,:)    = 0.0
+    local_H(:,:) = 0.0
+
+    DO k=1,klev
+       DO i = 1, knon
+          dels(i,k) = (pplay(i,k)/psref(i))**RKAPPA * delp(i,k)               
+          local_H(i,k) = RCPD * temp(i,k) * &
+               (psref(i)/pplay(i,k))**RKAPPA
+       ENDDO
+    ENDDO
+
+
+    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), dels(:,:), local_H(:,:), &
+         Ccoef_H(:,:), Dcoef_H(:,:))
+ 
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    petAcoef(1:knon) = Ccoef_H(1:knon,1)
+    peqAcoef(1:knon) = Ccoef_Q(1:knon,1)
+    petBcoef(1:knon) = Dcoef_H(1:knon,1)
+    peqBcoef(1:knon) = Dcoef_Q(1:knon,1)
+
+  END SUBROUTINE climb_hq_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, gama, dels, X, Ccoef, Dcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is H or Q, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*dels(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*dels(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = dels(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Ccoef(i,1) = (X(i,1)*dels(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Dcoef(i,1) = -1. * RG / buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
+       flx_q1, flx_t1, paprs, pplay, &
+       flux_q, flux_h, d_q, d_t)
+! 
+! This routine calculates the flux and tendency of the specific humidity q and 
+! the potential engergi H. 
+! The quantities q and H are calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_t1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)               :: zx_pkh, zx_pkf
+    REAL, DIMENSION(klon,klev)               :: h_new, q_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+!
+!****************************************************************************************
+    flux_q(:,:) = 0.0
+    flux_h(:,:) = 0.0
+    d_q(:,:)    = 0.0
+    d_t(:,:)    = 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+    DO k = 1, klev
+       DO i = 1, knon
+          zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA
+          zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA
+       END DO
+    END DO
+!****************************************************************************************
+! 2)
+! Calculation of Q and H
+!
+!****************************************************************************************
+
+!- First layer
+    q_new(1:knon,1) = Ccoef_Q(1:knon,1) + Dcoef_Q(1:knon,1)*flx_q1(1:knon)*dtime
+    h_new(1:knon,1) = Ccoef_H(1:knon,1) + Dcoef_H(1:knon,1)*flx_t1(1:knon)*dtime
+    
+!- All the rest layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
+          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for Q and H
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_q(1:knon,1)=flx_q1(1:knon)
+    flux_h(1:knon,1)=flx_t1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
+
+          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) / &
+               zx_pkh(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for Q and H
+!
+!****************************************************************************************
+
+    DO k = 1, klev
+       DO i = 1, knon
+          d_t(i,k) = h_new(i,k)/zx_pkf(i,k)/RCPD - t_old(i,k)
+          d_q(i,k) = q_new(i,k) - q_old(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H)    
+    DEALLOCATE(gamaq, gamah)
+    DEALLOCATE(Kcoefhq)
+
+    
+  END SUBROUTINE climb_hq_up
+!
+!****************************************************************************************
+!
+END MODULE climb_hq_mod
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/climb_wind_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/climb_wind_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/climb_wind_mod.F90	(revision 984)
@@ -0,0 +1,367 @@
+!
+! $Header$
+!
+MODULE climb_wind_mod
+!
+! Module to solve the verctical diffusion of the wind components "u" and "v".
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  SAVE
+  PRIVATE
+  
+  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
+  !$OMP THREADPRIVATE(alf1,alf2)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
+  !$OMP THREADPRIVATE(Kcoefm)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
+  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
+  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
+  LOGICAL                            :: firstcall=.TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+
+  
+  PUBLIC :: climb_wind_down, calcul_wind_flux, climb_wind_up
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_init
+
+    INTEGER             :: ierr
+    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
+
+!****************************************************************************************
+! Allocation of global module variables
+!
+!****************************************************************************************
+
+    ALLOCATE(alf1(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(alf2(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1)
+
+    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1)
+
+    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1)
+
+    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1)
+
+    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1)
+
+    firstcall=.FALSE.
+
+  END SUBROUTINE climb_wind_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old)
+!
+! This routine calculates for the wind components u and v,
+! recursivly the coefficients C and D in equation 
+! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
+!
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)                    :: u1lay, v1lay
+    INTEGER                                  :: k, i
+
+
+!****************************************************************************************
+! Initialize module
+    IF (firstcall) CALL climb_wind_init
+
+!****************************************************************************************
+! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
+!
+!****************************************************************************************
+
+! - Define alpha (alf1 and alf2) 
+    alf1(:) = 1.0
+    alf2(:) = 1.0 - alf1(:)
+
+! - Calculte the wind components for the first layer
+    u1lay(1:knon) = u_old(1:knon,1)*alf1(1:knon) + u_old(1:knon,2)*alf2(1:knon)
+    v1lay(1:knon) = v_old(1:knon,1)*alf1(1:knon) + v_old(1:knon,2)*alf2(1:knon)    
+
+! - Calculate K
+    Kcoefm(:,:) = 0.0
+    DO i = 1, knon
+       Kcoefm(i,1) = coef_in(i,1) * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))* &
+            pplay(i,1)/(RD*temp(i,1)) 
+       Kcoefm(i,1) = Kcoefm(i,1) * dtime*RG
+    END DO
+
+    DO k = 2, klev
+       DO i=1,knon
+          Kcoefm(i,k) = coef_in(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+          Kcoefm(i,k) = Kcoefm(i,k) * dtime*RG
+       END DO
+    END DO
+
+! - Calculate the coefficients C and D, component "u"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         u_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_U(:,:), Dcoef_U(:,:))
+
+! - Calculate the coefficients C and D, component "v"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         v_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_V(:,:), Dcoef_V(:,:))
+
+  END SUBROUTINE climb_wind_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, dels, X, alfa1, alfa2, Ccoef, Dcoef)
+!
+! Find the coefficients C and D in fonction of alfa, K and dels
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, dels
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+  
+! local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! 
+! Niveau au sommet, k=klev
+!
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = dels(i,klev) + Kcoef(i,klev)
+
+       Ccoef(i,klev) = X(i,klev)*dels(i,klev)/buf 
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+    
+! 
+! Niveau  (klev-1) <= k <= 2
+!
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = dels(i,k) + Kcoef(i,k) + &
+               Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          
+          Ccoef(i,k) = X(i,k)*dels(i,k) + &
+               Kcoef(i,k+1)*Ccoef(i,k+1)
+          Ccoef(i,k) = Ccoef(i,k)/buf         
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+! 
+! Niveau k=1
+!
+    DO i = 1, knon
+       buf = dels(i,1) + &
+            (alfa1(i) + alfa2(i)*Dcoef(i,2)) * Kcoef(i,1) + &
+            (1.-Dcoef(i,2))*Kcoef(i,2)
+       
+       Ccoef(i,1) = X(i,1)*dels(i,1) + &
+            (Kcoef(i,2)-Kcoef(i,1)*alfa2(i)) * Ccoef(i,2)
+       Ccoef(i,1) = Ccoef(i,1)/buf
+       Dcoef(i,1) = Kcoef(i,1)/buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE calcul_wind_flux(knon, dtime, &
+       flux_u, flux_v)
+
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    REAL, INTENT(IN)                     :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: u0, v0  ! u and v at niveau 0
+    REAL, DIMENSION(klon)                :: u1, v1  ! u and v at niveau 1
+    REAL, DIMENSION(klon)                :: u2, v2  ! u and v at niveau 2
+    
+
+!****************************************************************************************
+! Les vents de surface sont supposes nuls
+!
+!****************************************************************************************
+    u0(:) = 0.0
+    v0(:) = 0.0
+
+!****************************************************************************************
+! On calcule les vents du couhes 1 et 2 recurviement
+!
+!****************************************************************************************
+    DO i = 1, knon
+       u1(i) = Ccoef_U(i,1) + Dcoef_U(i,1)*u0(i)
+       v1(i) = Ccoef_V(i,1) + Dcoef_V(i,1)*v0(i)
+       u2(i) = Ccoef_U(i,2) + Dcoef_U(i,2)*u1(i)
+       v2(i) = Ccoef_V(i,2) + Dcoef_V(i,2)*v1(i)
+    END DO
+
+!****************************************************************************************
+! On calcule le flux
+!
+!****************************************************************************************
+    flux_u(:) = 0.0
+    flux_v(:) = 0.0
+
+    DO i=1,knon
+       flux_u(i) = Kcoefm(i,1)/RG/dtime * (u1(i)*alf1(i) + u2(i)*alf2(i) - u0(i)) 
+       flux_v(i) = Kcoefm(i,1)/RG/dtime * (v1(i)*alf1(i) + v2(i)*alf2(i) - v0(i)) 
+    END DO
+
+  END SUBROUTINE calcul_wind_flux
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, &
+       flx_u_new, flx_v_new, d_u_new, d_v_new)
+!
+! Diffuse the wind components from the surface and up to the top layer. Coefficents
+! C and D are known from before. The values for U and V at surface are supposed to be 
+! zero (this could be modified).
+!
+! u(k) = Cu(k) + Du(k)*u(k-1)
+! v(k) = Cv(k) + Dv(k)*v(k-1)
+! [1 <= k <= klev]
+!
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)              :: u_new, v_new
+    REAL, DIMENSION(klon)                   :: u0, v0
+    INTEGER                                 :: k, i
+    
+!
+!****************************************************************************************
+
+! Niveau 0
+    u0(1:knon) = 0.0
+    v0(1:knon) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       u_new(i,1) = Ccoef_U(i,1) + Dcoef_U(i,1) * u0(i)
+       v_new(i,1) = Ccoef_V(i,1) + Dcoef_V(i,1) * v0(i)
+    END DO
+
+! Niveau 2 jusqu'au sommet klev
+    DO k = 2, klev
+       DO i=1, knon
+          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
+          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul flux
+!
+!== flux_u/v est le flux de moment angulaire (positif vers bas)
+!== dont l'unite est: (kg m/s)/(m**2 s) 
+!
+!****************************************************************************************
+!
+    flx_u_new(:,:) = 0.0
+    flx_v_new(:,:) = 0.0
+
+! Niveau 1
+    DO i = 1, knon
+       flx_u_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (u_new(i,1)*alf1(i)+u_new(i,2)*alf2(i) - u0(i)) 
+       flx_v_new(i,1) = Kcoefm(i,1)/RG/dtime * &
+            (v_new(i,1)*alf1(i)+v_new(i,2)*alf2(i) - v0(i)) 
+    END DO
+
+! Niveau 2->klev
+    DO k = 2, klev
+       DO i = 1, knon
+          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (u_new(i,k)-u_new(i,k-1))
+          
+          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (v_new(i,k)-v_new(i,k-1))
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul tendances
+!
+!****************************************************************************************
+    d_u_new(:,:) = 0.0
+    d_v_new(:,:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
+          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
+       END DO
+    END DO
+
+  END SUBROUTINE climb_wind_up
+!
+!****************************************************************************************
+!
+END MODULE climb_wind_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/clouds_gno.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/clouds_gno.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/clouds_gno.F	(revision 984)
@@ -0,0 +1,262 @@
+!
+! $Header$
+!
+C
+C================================================================================
+C
+      SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF)
+      IMPLICIT NONE
+C     
+C--------------------------------------------------------------------------------
+C
+C Inputs:
+C
+C  ND----------: Number of vertical levels
+C  R--------ND-: Domain-averaged mixing ratio of total water 
+C  RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+C  QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+C                with SUBGRID-SCALE condensation processes (here, it is
+C                predicted by the convection scheme)
+C Outputs:
+C
+C  PTCONV-----ND-: Point convectif = TRUE
+C  RATQSC-----ND-: Largeur normalisee de la distribution
+C  CLDF-----ND-: Fraction nuageuse
+C
+C--------------------------------------------------------------------------------
+
+
+      INTEGER klon,ND
+      REAL R(klon,ND),  RS(klon,ND), QSUB(klon,ND)
+      LOGICAL PTCONV(klon,ND)
+      REAL RATQSC(klon,ND)
+      REAL CLDF(klon,ND)
+
+c -- parameters controlling the iteration:
+c --    nmax    : maximum nb of iterations (hopefully never reached)
+c --    epsilon : accuracy of the numerical resolution 
+c --    vmax    : v-value above which we use an asymptotic expression for ERF(v)
+
+      INTEGER nmax
+      PARAMETER ( nmax = 10) 
+      REAL epsilon, vmax0, vmax(klon)
+      PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) 
+
+      REAL min_mu, min_Q
+      PARAMETER ( min_mu =  1.e-12, min_Q=1.e-12 )
+     
+      INTEGER i,K, n, m
+      REAL mu(klon), qsat(klon), delta(klon), beta(klon) 
+      real zu2(klon),zv2(klon)
+      REAL xx(klon), aux(klon), coeff(klon), block(klon)
+      REAL  dist(klon), fprime(klon), det(klon)
+      REAL pi, u(klon), v(klon), erfcu(klon), erfcv(klon)
+      REAL  xx1(klon), xx2(klon)
+      real erf,kkk
+      real sqrtpi,sqrt2,zx1,zx2,exdel
+c lconv = true si le calcul a converge (entre autre si qsub < min_q)
+       LOGICAL lconv(klon)
+
+cym
+      cldf(:,:)=0.0
+      
+      pi = ACOS(-1.)
+      sqrtpi=sqrt(pi)
+      sqrt2=sqrt(2.)
+
+      ptconv=.false.
+      ratqsc=0.
+
+
+      DO 500 K = 1, ND
+
+                                    do i=1,klon ! vector
+      mu(i) = R(i,K)
+      mu(i) = MAX(mu(i),min_mu)
+      qsat(i) = RS(i,K) 
+      qsat(i) = MAX(qsat(i),min_mu)
+      delta(i) = log(mu(i)/qsat(i))
+                                    enddo ! vector
+
+C
+C ***          There is no subgrid-scale condensation;        ***
+C ***   the scheme becomes equivalent to an "all-or-nothing"  *** 
+C ***             large-scale condensation scheme.            ***
+C
+
+C
+C ***     Some condensation is produced at the subgrid-scale       ***
+C ***                                                              ***
+C ***       PDF = generalized log-normal distribution (GNO)        ***
+C ***   (k<0 because a lower bound is considered for the PDF)      ***
+C ***                                                              ***
+C ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+C ***  that the contribution of subgrid-scale processes to         ***
+C ***  the in-cloud water content is equal to QSUB(K)              ***
+C ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+C ***                                                              ***
+C ***    Here, an iterative method is used for this purpose        ***
+C ***    (other numerical methods might be more efficient)         ***
+C ***                                                              ***
+C ***          NB: the "error function" is called ERF              ***
+C ***                 (ERF in double precision)                   ***
+C
+
+c  On commence par eliminer les cas pour lesquels on n'a pas
+c  suffisamment d'eau nuageuse.
+
+                                    do i=1,klon ! vector
+
+      IF ( QSUB(i,K) .lt. min_Q ) THEN
+        ptconv(i,k)=.false.
+        ratqsc(i,k)=0.
+        lconv(i)  = .true.
+
+c   Rien on a deja initialise
+
+      ELSE 
+
+        lconv(i)  = .FALSE. 
+        vmax(i) = vmax0
+
+        beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) )
+
+c --  roots of equation v > vmax:
+
+        det(i) = delta(i) + vmax(i)**2.
+        if (det(i).LE.0.0) vmax(i) = vmax0 + 1.0
+        det(i) = delta(i) + vmax(i)**2.
+
+        if (det(i).LE.0.) then
+          xx(i) = -0.0001
+        else 
+         zx1=-sqrt2*vmax(i)
+         zx2=SQRT(1.0+delta(i)/(vmax(i)**2.))
+         xx1(i)=zx1*(1.0-zx2)
+         xx2(i)=zx1*(1.0+zx2)
+         xx(i) = 1.01 * xx1(i)
+         if ( xx1(i) .GE. 0.0 ) xx(i) = 0.5*xx2(i)
+        endif
+        if (delta(i).LT.0.) xx(i) = -0.5*SQRT(log(2.)) 
+
+      ENDIF
+
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Debut des nmax iterations pour trouver la solution.
+c----------------------------------------------------------------------
+
+      DO n = 1, nmax 
+
+                                    do i=1,klon ! vector
+        if (.not.lconv(i)) then
+
+          u(i) = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
+          v(i) = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
+
+          IF ( v(i) .GT. vmax(i) ) THEN 
+
+            IF (     ABS(u(i))  .GT. vmax(i) 
+     :          .AND.  delta(i) .LT. 0. ) THEN
+
+c -- use asymptotic expression of erf for u and v large:
+c ( -> analytic solution for xx )
+             exdel=beta(i)*EXP(delta(i))
+             aux(i) = 2.0*delta(i)*(1.-exdel)
+     :                       /(1.+exdel)
+             if (aux(i).lt.0.) then
+c                print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i)=0.
+             endif
+             xx(i) = -SQRT(aux(i))
+             block(i) = EXP(-v(i)*v(i)) / v(i) / sqrtpi
+             dist(i) = 0.0
+             fprime(i) = 1.0
+
+            ELSE
+
+c -- erfv -> 1.0, use an asymptotic expression of erfv for v large:
+
+             erfcu(i) = 1.0-ERF(u(i))
+c  !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+             aux(i) = sqrtpi*erfcu(i)*EXP(min(v(i)*v(i),100.))
+             coeff(i) = 1.0 - 1./2./(v(i)**2.) + 3./4./(v(i)**4.)
+             block(i) = coeff(i) * EXP(-v(i)*v(i)) / v(i) / sqrtpi
+             dist(i) = v(i) * aux(i) / coeff(i) - beta(i)
+             fprime(i) = 2.0 / xx(i) * (v(i)**2.)
+     :           * ( coeff(i)*EXP(-delta(i)) - u(i) * aux(i) )
+     :           / coeff(i) / coeff(i)
+            
+            ENDIF ! ABS(u)
+
+          ELSE
+
+c -- general case:
+
+           erfcu(i) = 1.0-ERF(u(i))
+           erfcv(i) = 1.0-ERF(v(i))
+           block(i) = erfcv(i)
+           dist(i) = erfcu(i) / erfcv(i) - beta(i)
+           zu2(i)=u(i)*u(i)
+           zv2(i)=v(i)*v(i)
+           if(zu2(i).gt.20..or. zv2(i).gt.20.) then
+c              print*,'ATTENTION !!! xx(',i,') =', xx(i)
+c           print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+c     .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+c     .CLDF(i,k)
+c              print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2(i)=20.
+              zv2(i)=20.
+             fprime(i) = 0.
+           else
+             fprime(i) = 2. /sqrtpi /xx(i) /erfcv(i)**2.
+     :           * (   erfcv(i)*v(i)*EXP(-zu2(i))
+     :               - erfcu(i)*u(i)*EXP(-zv2(i)) )
+           endif
+          ENDIF ! x
+
+c -- test numerical convergence:
+
+          if (beta(i).lt.1.e-10) then
+              print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i)
+              stop
+          endif
+          if (abs(fprime(i)).lt.1.e-11) then
+              print*,'avant test fprime<.e-11 '
+     s        ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i)
+              print*,'klon,ND,R,RS,QSUB',
+     s        klon,ND,R(i,k),rs(i,k),qsub(i,k)
+              fprime(i)=sign(1.e-11,fprime(i))
+          endif
+
+
+          if ( ABS(dist(i)/beta(i)) .LT. epsilon ) then 
+c           print*,'v-u **2',(v(i)-u(i))**2
+c           print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i,K) = .TRUE. 
+            lconv(i)=.true.
+c  borne pour l'exponentielle
+            ratqsc(i,k)=min(2.*(v(i)-u(i))**2,20.)
+            ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.)
+            CLDF(i,K) = 0.5 * block(i)
+          else
+            xx(i) = xx(i) - dist(i)/fprime(i)
+          endif
+c         print*,'apres test ',i,k,lconv(i)
+
+        endif ! lconv
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Fin des nmax iterations pour trouver la solution.
+        ENDDO ! n
+c----------------------------------------------------------------------
+
+500   CONTINUE  ! K
+
+       RETURN
+       END
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cltrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cltrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cltrac.F	(revision 984)
@@ -0,0 +1,122 @@
+!
+! $Header$
+!
+      SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp,
+     s                  d_tr)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+c            inspire de clvent
+c Objet: diffusion verticale de traceurs avec flux fixe a la surface
+c        ou/et flux du type c-drag
+c======================================================================
+c Arguments:
+c dtime----input-R- intervalle du temps (en second)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c tr-------input-R- la q. de traceurs
+c flux-----input-R- le flux de traceurs a la surface
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c cdrag----input-R- cdrag pour le flux de surface (non active)
+c tr0------input-R- traceurs a la surface ou dans l'ocean (non active)
+c d_tr-----output-R- le changement de tr
+c flux_tr--output-R- flux de tr
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL dtime
+      REAL coef(klon,klev)
+      REAL t(klon,klev), tr(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL d_tr(klon,klev)
+      REAL flux(klon), cdrag(klon), tr0(klon)
+c      REAL flux_tr(klon,klev)
+c======================================================================
+#include "YOMCST.h"
+c======================================================================
+      INTEGER i, k
+      REAL zx_ctr(klon,2:klev)
+      REAL zx_dtr(klon,2:klev)
+      REAL zx_buf(klon)
+      REAL zx_coef(klon,klev)
+      REAL local_tr(klon,klev)
+      REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon)
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+
+c======================================================================
+      DO i = 1, klon
+         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alf2(i) = 1.0 - zx_alf1(i)
+         zx_flux(i) =  -flux(i)*dtime*RG
+c--pour le moment le flux est prescrit
+c--cdrag et zx_coef(1) vaut 0
+         cdrag(i) = 0.0 
+         tr0(i) = 0.0
+         zx_coef(i,1) = cdrag(i)*dtime*RG 
+      ENDDO
+c======================================================================
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k)*dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+         zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+
+     .                  zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+         zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / 
+     .                  zx_buf(i)
+      ENDDO
+c
+      DO k = 3, klev
+      DO i = 1, klon
+         zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
+     .                  + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+         zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)
+     .                  +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+         zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev)
+     .                        +zx_coef(i,klev)*zx_ctr(i,klev) )
+     .                   / ( delp(i,klev) + zx_coef(i,klev)
+     .                       -zx_coef(i,klev)*zx_dtr(i,klev) )
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== flux_tr est le flux de traceur (positif vers bas)
+c      DO i = 1, klon
+c         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+c     .               * (local_tr(i,k)-local_tr(i,k-1))
+c      ENDDO
+c      ENDDO
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         d_tr(i,k) = local_tr(i,k) - tr(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cltracrn.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cltracrn.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cltracrn.F	(revision 984)
@@ -0,0 +1,294 @@
+!
+! $Header$
+!
+      SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay,
+     e              coef,t,ftsol,pctsrf,
+     e              tr,trs,paprs,pplay,delp,
+     e              masktr,fshtr,hsoltr,tautr,vdeptr,
+     e              lat,
+     s              d_tr,d_trs )
+
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Alex/LMD) date:  fev 99
+c            inspire de clqh + clvent
+c Objet: diffusion verticale de traceurs avec quantite de traceur ds 
+c        le sol ( reservoir de sol de radon ) 
+c        
+c note : pour l'instant le traceur dans le sol et le flux sont
+c        calcules mais ils ne servent que de diagnostiques
+c        seule la tendance sur le traceur est sortie (d_tr)
+c======================================================================
+c Arguments:
+c itr---  -input-R- le type de traceur 1- Rn 2 - Pb
+c dtime----input-R- intervalle du temps (en second)
+c u1lay----input-R- vent u de la premiere couche (m/s)
+c v1lay----input-R- vent v de la premiere couche (m/s)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c ftsol----input-R- temperature du sol (en Kelvin)
+c tr-------input-R- traceurs
+c trs------input-R- traceurs dans le sol
+c masktr---input-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----input-R- Flux surfacique de production dans le sol
+c tautr----input-R- Constante de decroissance du traceur
+c vdeptr---input-R- Vitesse de depot sec dans la couche brownienne
+c hsoltr---input-R- Epaisseur equivalente du reservoir de sol
+c lat-----input-R- latitude en degree
+c d_tr-----output-R- le changement de "tr"
+c d_trs----output-R- le changement de "trs"
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c======================================================================
+      REAL dtime
+      REAL u1lay(klon), v1lay(klon)
+      REAL coef(klon,klev)
+      REAL t(klon,klev), ftsol(klon,nbsrf), pctsrf(klon,nbsrf) 
+      REAL tr(klon,klev), trs(klon)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL masktr(klon) 
+      REAL fshtr(klon) 
+      REAL hsoltr
+      REAL tautr
+      REAL vdeptr
+      REAL lat(klon)   
+      REAL d_tr(klon,klev)
+c======================================================================
+      REAL flux_tr(klon,klev)  ! (diagnostic) flux de traceur
+      REAL d_trs(klon)         ! (diagnostic) traceur ds le sol
+c======================================================================
+      INTEGER i, k, itr, n, l
+      REAL rotrhi(klon)
+      REAL zx_coef(klon,klev)
+      REAL zx_buf(klon)
+      REAL zx_ctr(klon,klev)
+      REAL zx_dtr(klon,klev)
+      REAL zx_trs(klon)
+      REAL zx_a, zx_b
+
+      REAL local_tr(klon,klev)
+      REAL local_trs(klon)
+      REAL zts(klon)
+      REAL zx_alpha1(klon), zx_alpha2(klon)
+c======================================================================
+cAA Pour l'instant les 4 types de surface ne sont pas pris en compte
+cAA On fabrique avec zts un champ de temperature de sol  
+cAA que le pondere par la fraction de nature de sol.
+c 
+c      print*,'PASSAGE DANS CLTRACRN'
+
+      DO i = 1,klon
+            zts(i) = 0. 
+      ENDDO
+c
+      DO n=1,nbsrf
+         DO i = 1,klon
+            zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
+         ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+          rotrhi(i) = RD * zts(i) / hsoltr 
+      END DO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         local_trs(i) = trs(i)
+      ENDDO
+c======================================================================
+cAA   Attention si dans clmain zx_alf1(i) = 1.0 
+cAA   Il doit y avoir coherence (dc la meme chose ici)
+
+      DO i = 1, klon
+cAA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alpha1(i) = 1.0
+         zx_alpha2(i) = 1.0 - zx_alpha1(i)
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_coef(i,1) = coef(i,1)
+     .                 * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))
+     .                 * pplay(i,1)/(RD*t(i,1))
+         zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+      ENDDO
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
+         zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
+         zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
+      ENDDO
+c
+      DO l = klev-1, 2 , -1
+      DO i = 1, klon
+         zx_buf(i) = delp(i,l)+zx_coef(i,l)
+     .              +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
+         zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l)
+     .                   + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
+         zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))
+     .               + masktr(i) * zx_coef(i,1)
+     .               *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
+         zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)
+     .                  + zx_ctr(i,2)
+     .                  *(zx_coef(i,2)
+     .                    - masktr(i) * zx_coef(i,1)
+     .                    *zx_alpha2(i) ) ) / zx_buf(i)
+         zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
+      ENDDO
+c======================================================================
+c Calculer d'abord local_trs nouvelle quantite dans le reservoir
+c de sol
+c
+c-------------------------
+c Au dessus des continents
+c-------------------------
+c Le pb peut se deposer partout : vdeptr = 10-3 m/s
+c Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
+c
+      DO i = 1, klon
+c
+        IF ( NINT(masktr(i)) .EQ. 1 ) THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +fshtr(i)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+cAA: Pour l'instant, pour aller vite, le depot sec est traite
+C comme une decroissance
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c Si on est entre 60N et 70N on divise par 2 l'emanation
+c--------------------------------------------------------
+c
+        IF
+     .  ( (itr.eq.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.)
+     .                      .OR.
+     .     (itr.eq.2.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.) )
+     .  THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +(fshtr(i)/2.)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c----------------------------------------------
+c Au dessus des oceans et aux hautes latitudes
+c----------------------------------------------
+c
+c au dessous de -60S  pas d'emission de radon au dessus 
+c des oceans et des continents
+c---------------------------------------------------------------
+
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c au dessus de 70 N pas d'emission de radon au dessus 
+c des oceans et des continents
+c--------------------------------------------------------------
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c Au dessus des oceans la source est nulle
+c-----------------------------------------
+c
+        IF (itr.eq.1.AND.NINT(masktr(i)).EQ.0) THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+c
+      ENDDO    ! sur le i=1,klon
+c
+c======================================================================
+c==== une fois on a zx_trs, on peut faire l'iteration ========
+c
+      DO i = 1, klon
+         local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        local_tr(i,l)
+     .    = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul du flux de traceur (flux_tr): UA/(m**2 s)
+c
+      DO i = 1, klon
+        flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG
+     .      * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2)
+     .                   -zx_trs(i)) / dtime
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        flux_tr(i,l) = zx_coef(i,l)/RG
+     .       * (local_tr(i,l)-local_tr(i,l-1)) / dtime
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul des tendances du traceur ds le sol et dans l'atmosphere
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_tr(i,l) = local_tr(i,l) - tr(i,l)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         d_trs(i) = local_trs(i) - trs(i)
+      ENDDO
+c======================================================================
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/coef_diff_turb_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/coef_diff_turb_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/coef_diff_turb_mod.F90	(revision 984)
@@ -0,0 +1,645 @@
+!
+! $Header$
+!
+MODULE coef_diff_turb_mod
+!
+! This module contains some procedures for calculation of the coefficients of the
+! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
+! at surface(cdrag)
+!
+  USE dimphy
+  
+  IMPLICIT NONE
+  
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, &
+       ycoefm, ycoefh ,yq2)
+! 
+! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+! atmosphere and coefficients for turbulent diffusion at surface - cdrag
+! (ycoefm(:,1), ycoefh(:,1)).
+!
+!
+! Input arguments
+!****************************************************************************************
+    REAL, INTENT(IN)                           :: dtime
+    INTEGER, INTENT(IN)                        :: nsrf, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
+    REAL, DIMENSION(klon,klev+1)               :: yq2
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                    :: k, i, j
+    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
+    REAL, DIMENSION(klon,klev+1)               :: yzlev, q2diag, ykmm, ykmn, ykmq
+    REAL, DIMENSION(klon)                      :: y_cd_h, y_cd_m
+    REAL, DIMENSION(klon)                      :: yustar
+
+! Include
+!****************************************************************************************
+    INCLUDE "clesphys.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "YOMCST.h"
+
+!****************************************************************************************
+! Start calculation
+! - Initilalize output variables 
+!****************************************************************************************
+
+    ycoefm(:,:) = 0.0
+    ycoefh(:,:) = 0.0
+
+
+!****************************************************************************************    
+! Methode 1 :
+!
+!****************************************************************************************    
+
+    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
+         ksta, ksta_ter, &
+         yts, yrugos, yu, yv, yt, yq, &
+         yqsurf, &
+         ycoefm, ycoefh)
+  
+!****************************************************************************************
+! Methode 2 :
+!
+!****************************************************************************************
+
+    IF (iflag_pbl.EQ.1) THEN
+       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
+            ycoefm0, ycoefh0)
+
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+    ENDIF
+
+!****************************************************************************************
+! IM cf JLD : on seuille ycoefm et ycoefh
+!
+!****************************************************************************************
+    IF (nsrf.EQ.is_oce) THEN
+       DO j=1,knon
+          ycoefm(j,1)=MIN(ycoefm(j,1),cdmmax)
+          ycoefh(j,1)=MIN(ycoefh(j,1),cdhmax)
+       ENDDO
+    ENDIF
+  
+!****************************************************************************************  
+! Calcul d'une diffusion minimale pour les conditions tres stables
+!
+!****************************************************************************************
+    IF (ok_kzmin) THEN
+       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycoefm, &
+            ycoefm0,ycoefh0)
+       
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+       
+    ENDIF
+
+  
+!****************************************************************************************
+! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
+! Methode 3 :
+!****************************************************************************************
+
+    IF (iflag_pbl.GE.3) THEN
+
+       yzlay(1:knon,1)= &
+            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+          DO i = 1, knon
+             yzlay(i,k)= &
+                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
+                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+          END DO
+       END DO
+
+       DO k=1,klev
+          DO i = 1, knon
+             yteta(i,k)= &
+                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
+                  *(1.+0.61*yq(i,k))
+          END DO
+       END DO
+
+       yzlev(1:knon,1)=0.
+       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
+       DO k=2,klev
+          DO i = 1, knon
+             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+          END DO
+       END DO
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
+! bug sur les coefficients de surface :
+!          y_cd_h(1:knon) = ycoefm(1:knon,1)
+!          y_cd_m(1:knon) = ycoefh(1:knon,1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+       y_cd_m(1:knon) = ycoefm(1:knon,1)
+       y_cd_h(1:knon) = ycoefh(1:knon,1)
+       
+       CALL ustarhb(knon,yu,yv,y_cd_m, yustar)
+     
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*) 'USTAR = ',yustar
+       ENDIF
+         
+!   iflag_pbl peut etre utilise comme longuer de melange
+       IF (iflag_pbl.GE.11) THEN
+          CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,q2diag,ykmm,ykmn,yustar, &
+               iflag_pbl)
+       ELSE
+          CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               y_cd_m,yq2,ykmm,ykmn,ykmq,yustar, &
+               iflag_pbl)
+       ENDIF
+       
+       ycoefm(1:knon,1)=y_cd_m(1:knon)
+       ycoefh(1:knon,1)=y_cd_h(1:knon)
+       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
+       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
+                
+    ENDIF !(iflag_pbl.ge.3)
+
+  END SUBROUTINE coef_diff_turb
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
+       ksta, ksta_ter, &
+       ts, rugos, &
+       u,v,t,q, &
+       qsurf, &
+       pcfm, pcfh)
+    
+!======================================================================
+! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+!           (une version strictement identique a l'ancien modele)
+! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+!        coefficients d'echange turbulent dans l'atmosphere.
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pregssion a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! ts-------input-R- temperature du sol (en Kelvin)
+! rugos----input-R- longeur de rugosite (en m)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOMCST.h"
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                      :: knon, nsrf
+    REAL, DIMENSION(klon), INTENT(IN)        :: ts
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
+
+
+! Local variables
+
+! numero de couche du sommet de la couche limite
+    INTEGER, DIMENSION(klon)    :: itop
+!
+! Quelques constantes et options:
+!
+    REAL cepdu2, ckap, cb, cc, cd, clam
+    PARAMETER (cepdu2 =(0.1)**2)
+    PARAMETER (CKAP=0.4)
+    PARAMETER (cb=5.0)
+    PARAMETER (cc=5.0)
+    PARAMETER (cd=5.0)
+    PARAMETER (clam=160.0)
+    REAL ratqs ! largeur de distribution de vapeur d'eau
+    PARAMETER (ratqs=0.05)
+    LOGICAL richum ! utilise le nombre de Richardson humide
+    PARAMETER (richum=.TRUE.)
+    REAL ric ! nombre de Richardson critique
+    PARAMETER(ric=0.4)
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable ! diffusion minimale (situation stable)
+    ! GKtest
+    ! PARAMETER (kstable=1.0e-10)
+    REAL ksta, ksta_ter
+!IM: 261103     REAL kstable_ter, kstable_sinon
+!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
+!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
+!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
+!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
+    ! fin GKtest
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    INTEGER isommet ! le sommet de la couche limite
+    LOGICAL tvirtu ! calculer Ri d'une maniere plus performante
+    PARAMETER (tvirtu=.TRUE.)
+    LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
+    PARAMETER (opt_ec=.FALSE.)
+
+!
+! Variables locales:
+
+    INTEGER i, k !IM 120704
+    REAL zgeop(klon,klev)
+    REAL zmgeom(klon)
+    REAL zri(klon)
+    REAL zl2(klon)
+    
+    REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon)
+    REAL pcfm1(klon), pcfh1(klon)
+
+    REAL zdphi, zdu2, ztvd, ztvu, zcdn
+    REAL zscf
+    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+    REAL t_coup
+    PARAMETER (t_coup=273.15)
+!IM
+    LOGICAL check
+    PARAMETER (check=.FALSE.)
+!
+! contre-gradient pour la chaleur sensible: Kelvin/metre
+    REAL gamt(2:klev)
+    REAL qsurf(klon) 
+
+    LOGICAL, SAVE :: appel1er
+    !$OMP THREADPRIVATE(appel1er)
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+    REAL fsta, fins, x
+    LOGICAL zxli ! utiliser un jeu de fonctions simples
+    PARAMETER (zxli=.FALSE.)
+
+    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+    fins(x) = SQRT(1.0-18.0*x)
+
+    DATA appel1er /.TRUE./
+
+
+    isommet=klev
+      
+    IF (appel1er) THEN
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
+          WRITE(lunout,*)'coefkz, richum:', richum
+          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
+          WRITE(lunout,*)'coefkz, isommet:', isommet
+          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
+          appel1er = .FALSE.
+       ENDIF
+    ENDIF
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+    DO i = 1, knon
+       itop(i) = 0
+    ENDDO
+    
+!
+! Prescrire la valeur de contre-gradient
+!
+    IF (iflag_pbl.EQ.1) THEN
+       DO k = 3, klev
+          gamt(k) = -1.0E-03
+       ENDDO
+       gamt(2) = -2.5E-03
+    ELSE
+       DO k = 2, klev
+          gamt(k) = 0.0
+       ENDDO
+    ENDIF
+!IM cf JLD/ GKtest
+    IF ( nsrf .NE. is_oce ) THEN
+!IM 261103     kstable = kstable_ter
+       kstable = ksta_ter
+    ELSE
+!IM 261103     kstable = kstable_sinon
+       kstable = ksta
+    ENDIF
+!IM cf JLD/ GKtest fin
+
+!
+! Calculer les geopotentiels de chaque couche
+!
+    DO i = 1, knon
+       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+            * (paprs(i,1)-pplay(i,1))
+    ENDDO
+    DO k = 2, klev
+       DO i = 1, knon
+          zgeop(i,k) = zgeop(i,k-1) &
+               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+               * (pplay(i,k-1)-pplay(i,k))
+       ENDDO
+    ENDDO
+
+!
+! Calculer le frottement au sol (Cdrag)
+!
+    DO i = 1, knon
+       u1(i) = u(i,1)
+       v1(i) = v(i,1)
+       t1(i) = t(i,1)
+       q1(i) = q(i,1)
+       z1(i) = zgeop(i,1)
+    ENDDO
+
+    CALL clcdrag(klon, knon, nsrf, zxli, &
+         u1, v1, t1, q1, z1, &
+         ts, qsurf, rugos, &
+         pcfm1, pcfh1) 
+!IM               ts, qsurf, rugos,
+
+    DO i = 1, knon
+       pcfm(i,1)=pcfm1(i)
+       pcfh(i,1)=pcfh1(i)
+    ENDDO
+!
+! Calculer les coefficients turbulents dans l'atmosphere
+!
+    DO i = 1, knon
+       itop(i) = isommet
+    ENDDO
+
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
+               +(v(i,k)-v(i,k-1))**2)
+          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+          zdphi =zmgeom(i) / 2.0
+          zt = (t(i,k)+t(i,k-1)) * 0.5
+          zq = (q(i,k)+q(i,k-1)) * 0.5
+
+!
+! Calculer Qs et dQs/dT:
+!
+          IF (thermcep) THEN
+             zdelta = MAX(0.,SIGN(1.,RTT-zt))
+             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
+                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+             zqs = MIN(0.5,zqs)
+             zcor = 1./(1.-RETV*zqs)
+             zqs = zqs*zcor
+             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+          ELSE
+             IF (zt .LT. t_coup) THEN
+                zqs = qsats(zt) / pplay(i,k)
+                zdqs = dqsats(zt,zqs)
+             ELSE
+                zqs = qsatl(zt) / pplay(i,k)
+                zdqs = dqsatl(zt,zqs)
+             ENDIF
+          ENDIF
+!
+!           calculer la fraction nuageuse (processus humide):
+!
+          zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+          zfr = MAX(0.0,MIN(1.0,zfr))
+          IF (.NOT.richum) zfr = 0.0
+!
+!           calculer le nombre de Richardson:
+!
+          IF (tvirtu) THEN
+             ztvd =( t(i,k) &
+                  + zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k))
+             ztvu =( t(i,k-1) &
+                  - zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k-1))
+             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+             zri(i) = zri(i) &
+                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(ztvd+ztvu))
+
+          ELSE ! calcul de Ridchardson compatible LMD5
+
+             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
+                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
+                  *(pplay(i,k)-pplay(i,k-1)) &
+                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+             zri(i) = zri(i) + &
+                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+          ENDIF
+!
+!           finalement, les coefficients d'echange sont obtenus:
+!
+          zcdn=SQRT(zdu2) / zmgeom(i) * RG
+
+          IF (opt_ec) THEN
+             z2geomf=zgeop(i,k-1)+zgeop(i,k)
+             zalm2=(0.5*ckap/RG*z2geomf &
+                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
+             zalh2=(0.5*ckap/rg*z2geomf &
+                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+             IF (zri(i).LT.0.0) THEN  ! situation instable
+                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
+                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+                zscf = SQRT(-zri(i)*zscf)
+                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+             ELSE ! situation stable
+                zscf=SQRT(1.+cd*zri(i))
+                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+             ENDIF
+          ELSE
+             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
+                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+             pcfm(i,k)= zl2(i)* pcfm(i,k)
+             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Au-dela du sommet, pas de diffusion turbulente:
+!
+    DO i = 1, knon
+       IF (itop(i)+1 .LE. klev) THEN
+          DO k = itop(i)+1, klev
+             pcfh(i,k) = 0.0
+             pcfm(i,k) = 0.0
+          ENDDO
+       ENDIF
+    ENDDO
+      
+  END SUBROUTINE coefkz
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
+       pcfm, pcfh)
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: knon, nsrf
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
+    
+    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
+!
+! Quelques constantes et options:
+!
+    REAL prandtl
+    PARAMETER (prandtl=0.4)
+    REAL kstable
+    PARAMETER (kstable=0.002)
+!    PARAMETER (kstable=0.001)
+    REAL mixlen ! constante controlant longueur de melange
+    PARAMETER (mixlen=35.0)
+    REAL seuil ! au-dela l'inversion est consideree trop faible
+    PARAMETER (seuil=-0.02)
+!    PARAMETER (seuil=-0.04)
+!    PARAMETER (seuil=-0.06)
+!    PARAMETER (seuil=-0.09)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(knon)
+    REAL zl2(knon)
+    REAL zdthmin(knon), zdthdp
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+
+!
+! Chercher la zone d'inversion forte
+!
+    DO i = 1, knon
+       invb(i) = klev
+       zdthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, knon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.zdthmin(i) ) THEN
+             zdthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Introduire une diffusion:
+!
+    IF ( nsrf.EQ.is_oce ) THEN
+       DO k = 2, klev
+          DO i = 1, knon
+!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+      !IM cf JLD/ GKtest TERkz2
+      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
+      ! fin GKtest
+
+
+! s'il n'y a pas d'inversion ou si l'inversion est trop faible
+!          IF ( (nsrf.EQ.is_oce) .AND. &
+             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
+                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
+                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
+                pcfm(i,k)= zl2(i)* kstable
+                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE coefkz2
+!
+!****************************************************************************************
+!
+END MODULE coef_diff_turb_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/coefcdrag.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/coefcdrag.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/coefcdrag.F90	(revision 984)
@@ -0,0 +1,147 @@
+!
+! $Header$
+!
+!
+!
+!
+      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
+                            speed, t, q, zgeop, psol, &
+                            ts, qsurf, rugos, okri, ri1, &
+                            cdram, cdrah, cdran, zri1, pref)
+      IMPLICIT none
+!-------------------------------------------------------------------------
+! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
+!         sensible et latente (cdrah), du cdrag neutre (cdran), 
+!         du nombre de Richardson entre la surface et le niveau de reference 
+!         (zri1) et de la pression au niveau de reference (pref).    
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! psol----input-R- pression au sol 
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
+!
+! cdram--output-R- cdrag pour le moment
+! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
+! cdran--output-R- cdrag neutre
+! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
+! pref---output-R- pression au niveau zgeop/RG
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli 
+      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
+      LOGICAL, intent(in) :: okri    
+!
+      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
+!-------------------------------------------------------------------------
+!
+      include "YOMCST.h"
+      include "YOETHF.h"
+      include "indicesol.h"
+! Quelques constantes :
+      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0
+!
+! Variables locales :
+      INTEGER :: i
+      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
+      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
+      REAL, dimension(klon) :: zcfm1, zcfh1
+      REAL, dimension(klon) :: zcfm2, zcfh2
+      REAL, dimension(klon) :: trm0, trm1
+!-------------------------------------------------------------------------
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+!-------------------------------------------------------------------------
+!
+      DO i = 1, knon
+!
+       zdphi(i) = zgeop(i)
+       zdu2(i) = speed(i)**2
+       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
+                 (1.+ RETV * max(q(i),0.0))))
+       ztsolv(i) = ts(i)
+       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
+       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
+       trm1(i) = 1. + RETV * max(q(i),0.0)
+       ztsolv(i) = ztsolv(i) * trm0(i)
+       ztvd(i) = ztvd(i) * trm1(i)
+       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
+!
+! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
+!
+!IM +++
+       IF(1.EQ.0) THEN
+       IF (okri) THEN
+         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
+           zri1(i) = ri1(i)
+         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
+           zri1(i) = ri1(i)
+         ENDIF 
+       ENDIF
+       ENDIF
+!IM ---
+! 
+       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
+
+       IF (zri1(i) .ge. 0.) THEN 
+!
+! situation stable : pour eviter les inconsistances dans les cas 
+! tres stables on limite zri1 a 20. cf Hess et al. (1995)
+!
+         zri1(i) = min(20.,zri1(i))
+!
+         IF (.NOT.zxli) THEN
+           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
+           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1)
+           zcfm1(i) = cdran(i) * friv(i)
+           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 )
+           zcfh1(i) = cdran(i) * frih(i)
+           cdram(i) = zcfm1(i)
+           cdrah(i) = zcfh1(i)
+         ELSE
+           cdram(i) = cdran(i)* fsta(zri1(i))
+           cdrah(i) = cdran(i)* fsta(zri1(i))
+         ENDIF
+!
+       ELSE
+! 
+! situation instable
+!
+         IF (.NOT.zxli) THEN
+           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
+                 *(1.0+zdphi(i)/(RG*rugos(i)))))
+           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1)
+           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
+           cdram(i) = zcfm2(i)
+           cdrah(i) = zcfh2(i)
+         ELSE
+           cdram(i) = cdran(i)* fins(zri1(i))
+           cdrah(i) = cdran(i)* fins(zri1(i))
+         ENDIF
+!
+! cdrah sur l'ocean cf. Miller et al. (1992)
+!
+         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
+               **(1./3.)
+         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
+                  **(1./1.25)
+       ENDIF
+!
+      END DO
+      RETURN 
+      END SUBROUTINE coefcdrag
Index: LMDZ4/tags/LF_20080728/libf/phytherm/coefkzmin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/coefkzmin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/coefkzmin.F	(revision 984)
@@ -0,0 +1,136 @@
+!
+! $Header$
+!
+       SUBROUTINE coefkzmin(ngrid,ypaprs,ypplay,yu,yv,yt,yq,ycoefm
+     .   ,km,kn)
+c      SUBROUTINE coefkzmin(ngrid,zlev,teta,ustar,km,kn)
+      USE dimphy
+      IMPLICIT NONE
+
+      include "YOMCST.h"
+
+c.......................................................................
+c  Entrees modifies en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+
+      REAL  ycoefm(klon,klev)
+
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      REAL ypaprs(klon,klev+1), ypplay(klon,klev)
+      REAL yustar(klon)
+      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
+
+      integer i
+
+c.......................................................................
+c
+c  En entree :
+c  -----------
+c
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c ustar : u*
+c
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c
+c  en sortier :
+c  ------------
+c
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL teta(klon,klev)
+
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer ngrid
+
+
+      integer nlay,nlev
+      integer ig,k
+
+      real,parameter :: kap=0.4
+
+      nlay=klev
+      nlev=klev+1
+c.......................................................................
+c  en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+c  Debut de la partie qui doit etre unclue a terme dans clmain.
+c
+         do i=1,ngrid
+            yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1)))
+     .                *(ypaprs(i,1)-ypplay(i,1))/RG
+         enddo
+         do k=2,klev
+            do i=1,ngrid
+               yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k))
+     s                /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+            enddo
+         enddo
+         do k=1,klev
+            do i=1,ngrid
+cATTENTION:on passe la temperature potentielle virt. pour le calcul de K
+             yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa
+     s          *(1.+0.61*yq(i,k))
+            enddo
+         enddo
+         do i=1,ngrid
+            yzlev(i,1)=0.
+            yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1)
+         enddo
+         do k=2,klev
+            do i=1,ngrid
+               yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+            enddo
+         enddo
+
+
+cIM cf FH   yustar(:) =SQRT(ycoefm(:,1)*(yu(:,1)*yu(:,1)+yv(:,1)*yv(:,1)))
+      yustar(1:ngrid) =SQRT(ycoefm(1:ngrid,1)*
+     $       (yu(1:ngrid,1)*yu(1:ngrid,1)+yv(1:ngrid,1)*yv(1:ngrid,1)))
+
+c  Fin de la partie qui doit etre unclue a terme dans clmain.
+
+Cette routine est ecrite pour avoir en entree ustar, teta et zlev
+c  Ici, on a inclut le calcul de ces trois variables dans la routine
+c  coefkzmin en attendant une nouvelle version de la couche limite
+c  ou ces variables seront disponibles.
+
+c Debut de la routine coefkzmin proprement dite.
+
+      ustar=yustar
+      teta=yteta
+      zlev=yzlev
+
+      do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+      enddo
+      
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=0. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            kn(ig,k)=kmin
+            km(ig,k)=kmin
+         enddo
+      enddo
+
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/comgeomphy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/comgeomphy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/comgeomphy.F90	(revision 984)
@@ -0,0 +1,23 @@
+module comgeomphy
+   real,save,allocatable :: airephy(:)
+   real,save,allocatable :: cuphy(:)
+   real,save,allocatable :: cvphy(:)
+   real,save,allocatable :: rlatd(:)
+   real,save,allocatable :: rlond(:)
+!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond)
+contains
+  
+  subroutine InitComgeomphy
+  USE mod_phys_lmdz_para
+  implicit none
+    
+ 
+    allocate(airephy(klon_omp))
+    allocate(cuphy(klon_omp))
+    allocate(cvphy(klon_omp))
+    allocate(rlatd(klon_omp))
+    allocate(rlond(klon_omp))
+
+  end subroutine InitComgeomphy
+  
+end module comgeomphy
Index: LMDZ4/tags/LF_20080728/libf/phytherm/comgeomphy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/comgeomphy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/comgeomphy.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+c
+c
+c Common de passage de la geometrie de la dynamique a la physique
+      real airephy(klon),cuphy(klon),cvphy(klon)
+      REAL rlatd(klon), rlond(klon)
+      common/comgeomphy/airephy,cuphy,cvphy,rlatd, rlond
Index: LMDZ4/tags/LF_20080728/libf/phytherm/compbl.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/compbl.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/compbl.h	(revision 984)
@@ -0,0 +1,6 @@
+      !
+      ! $Header$
+      !
+      integer iflag_pbl
+      common/compbl/iflag_pbl
+!$OMP THREADPRIVATE(/compbl/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conccm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conccm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conccm.F	(revision 984)
@@ -0,0 +1,835 @@
+!
+! $Header$
+!
+      SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q,
+     s                   d_t, d_q, rain, snow, kbascm, ktopcm)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996
+c Objet: Schema simple (avec flux de masse) pour la convection 
+c        (schema standard du modele NCAR CCM2)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Entree:
+      REAL dtime              ! pas d'integration
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (g/g)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c Sortie:
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation vapeur
+      REAL rain(klon)         ! pluie (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER kbascm(klon)    ! niveau du bas de convection
+      INTEGER ktopcm(klon)    ! niveau du haut de convection
+c
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pres(klon,klev)
+      REAL dp(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL cmfprs(klon)
+      REAL cmfprt(klon)
+      INTEGER ntop(klon)
+      INTEGER nbas(klon)
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql_bis(klon,klev)
+      REAL rneb_bis(klon,klev)
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kbascm(i) = 0
+         ktopcm(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         pres(i,k) = pplay(i,klev-k+1)
+         dp(i,k) = paprs(i,klev+1-k)-paprs(i,klev+1-k+1)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                      * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgeom(i,klev+1-k) = zgeom(i,klev+1-k+1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+      CALL cmfmca(dtime, pres, dp, zgeom, pt, pq,
+     $                  cmfprt, cmfprs, ntop, nbas)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = pq(i,k) - q(i,klev+1-k) 
+         d_t(i,klev+1-k) = pt(i,k) - t(i,klev+1-k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         rain(i) = cmfprt(i) * rhoh2o
+         snow(i) = cmfprs(i) * rhoh2o
+         kbascm(i) = klev+1 - nbas(i)
+         ktopcm(i) = klev+1 - ntop(i)
+      ENDDO
+c
+      IF (usekuo) THEN
+      CALL conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s            d_t_bis, d_q_bis, d_ql_bis, rneb_bis,
+     s            rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         kbascm(i) = MIN(kbascm(i),ibas_bis(i))
+         ktopcm(i) = MAX(ktopcm(i),itop_bis(i))
+      ENDDO
+      DO k = 1, klev ! eau liquide convective est
+      DO i = 1, klon ! dispersee dans l'air
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql_bis(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE cmfmca(deltat, p, dp, gz,
+     $                  tb, shb,
+     $                  cmfprt, cmfprs, cnt, cnb)
+      USE dimphy
+      IMPLICIT none
+C-----------------------------------------------------------------------
+C Moist convective mass flux procedure:
+C If stratification is unstable to nonentraining parcel ascent,
+C complete an adjustment making use of a simple cloud model
+C 
+C Code generalized to allow specification of parcel ("updraft")
+C properties, as well as convective transport of an arbitrary
+C number of passive constituents (see cmrb array).
+C----------------------------Code History-------------------------------
+C Original version:  J. J. Hack, March 22, 1990
+C Standardized:      J. Rosinski, June 1992
+C Reviewed:          J. Hack, G. Taylor, August 1992
+c Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994,
+c                    J. Geophys. Res. vol 99, D3, 5551-5568). J'ai
+c                    introduit les constantes et les fonctions thermo-
+c                    dynamiques du Centre Europeen. J'ai elimine le
+c                    re-indicage du code en esperant que cela pourra
+c                    simplifier la lecture et la comprehension.
+C-----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      INTEGER pcnst ! nombre de traceurs passifs
+      PARAMETER (pcnst=1)
+C------------------------------Arguments--------------------------------
+C Input arguments
+C
+      REAL deltat                 ! time step (seconds)
+      REAL p(klon,klev)           ! pressure
+      REAL dp(klon,klev)          ! delta-p
+      REAL gz(klon,klev)          ! geopotential (a partir du sol)
+c
+      REAL thtap(klon)            ! PBL perturbation theta
+      REAL shp(klon)              ! PBL perturbation specific humidity 
+      REAL pblh(klon)             ! PBL height (provided by PBL routine)
+      REAL cmrp(klon,pcnst)       ! constituent perturbations in PBL
+c
+c Updated arguments:
+c
+      REAL tb(klon,klev)         ! temperature (t bar)
+      REAL shb(klon,klev)        ! specific humidity (sh bar)
+      REAL cmrb(klon,klev,pcnst) ! constituent mixing ratios (cmr bar)
+C
+C Output arguments
+C
+      REAL cmfdt(klon,klev)    ! dT/dt due to moist convection
+      REAL cmfdq(klon,klev)    ! dq/dt due to moist convection
+      REAL cmfmc(klon,klev )   ! moist convection cloud mass flux
+      REAL cmfdqr(klon,klev)   ! dq/dt due to convective rainout 
+      REAL cmfsl(klon,klev )   ! convective lw static energy flux
+      REAL cmflq(klon,klev )   ! convective total water flux
+      REAL cmfprt(klon)        ! convective precipitation rate
+      REAL cmfprs(klon)        ! convective snowfall rate
+      REAL qc(klon,klev)       ! dq/dt due to rainout terms
+      INTEGER cnt(klon)        ! top level of convective activity   
+      INTEGER cnb(klon)        ! bottom level of convective activity
+C------------------------------Parameters-------------------------------
+      REAL c0         ! rain water autoconversion coefficient
+      PARAMETER (c0=1.0e-4)
+      REAL dzmin       ! minimum convective depth for precipitation
+      PARAMETER (dzmin=0.0)
+      REAL betamn      ! minimum overshoot parameter
+      PARAMETER (betamn=0.10)
+      REAL cmftau      ! characteristic adjustment time scale
+      PARAMETER (cmftau=3600.)
+      INTEGER limcnv   ! top interface level limit for convection
+      PARAMETER (limcnv=1)
+      REAL tpmax       ! maximum acceptable t perturbation (degrees C)
+      PARAMETER (tpmax=1.50)
+      REAL shpmax      ! maximum acceptable q perturbation (g/g)
+      PARAMETER (shpmax=1.50e-3)
+      REAL tiny        ! arbitrary small num used in transport estimates
+      PARAMETER (tiny=1.0e-36)
+      REAL eps         ! convergence criteria (machine dependent)
+      PARAMETER (eps=1.0e-13)
+      REAL tmelt       ! freezing point of water(req'd for rain vs snow)
+      PARAMETER (tmelt=273.15)
+      REAL ssfac ! supersaturation bound (detrained air)
+      PARAMETER (ssfac=1.001)
+C
+C---------------------------Local workspace-----------------------------
+      REAL gam(klon,klev)     ! L/cp (d(qsat)/dT)
+      REAL sb(klon,klev)      ! dry static energy (s bar)
+      REAL hb(klon,klev)      ! moist static energy (h bar)
+      REAL shbs(klon,klev)    ! sat. specific humidity (sh bar star)
+      REAL hbs(klon,klev)     ! sat. moist static energy (h bar star)
+      REAL shbh(klon,klev+1)  ! specific humidity on interfaces
+      REAL sbh(klon,klev+1)   ! s bar on interfaces
+      REAL hbh(klon,klev+1)   ! h bar on interfaces
+      REAL cmrh(klon,klev+1)  ! interface constituent mixing ratio 
+      REAL prec(klon)         ! instantaneous total precipitation
+      REAL dzcld(klon)        ! depth of convective layer (m)
+      REAL beta(klon)         ! overshoot parameter (fraction)
+      REAL betamx             ! local maximum on overshoot
+      REAL eta(klon)          ! convective mass flux (kg/m^2 s)
+      REAL etagdt             ! eta*grav*deltat
+      REAL cldwtr(klon)       ! cloud water (mass)
+      REAL rnwtr(klon)        ! rain water  (mass)
+      REAL sc  (klon)         ! dry static energy   ("in-cloud")
+      REAL shc (klon)         ! specific humidity   ("in-cloud")
+      REAL hc  (klon)         ! moist static energy ("in-cloud")
+      REAL cmrc(klon)         ! constituent mix rat ("in-cloud")
+      REAL dq1(klon)          ! shb  convective change (lower lvl)
+      REAL dq2(klon)          ! shb  convective change (mid level)
+      REAL dq3(klon)          ! shb  convective change (upper lvl)
+      REAL ds1(klon)          ! sb   convective change (lower lvl)
+      REAL ds2(klon)          ! sb   convective change (mid level)
+      REAL ds3(klon)          ! sb   convective change (upper lvl)
+      REAL dcmr1(klon)        ! cmrb convective change (lower lvl)
+      REAL dcmr2(klon)        ! cmrb convective change (mid level)
+      REAL dcmr3(klon)        ! cmrb convective change (upper lvl)
+      REAL flotab(klon)       ! hc - hbs (mesure d'instabilite)
+      LOGICAL ldcum(klon)     ! .true. si la convection existe
+      LOGICAL etagt0          ! true if eta > 0.0
+      REAL dt                 ! current 2 delta-t (model time step)
+      REAL cats     ! modified characteristic adj. time
+      REAL rdt      ! 1./dt
+      REAL qprime   ! modified specific humidity pert.
+      REAL tprime   ! modified thermal perturbation
+      REAL pblhgt   ! bounded pbl height (max[pblh,1m])
+      REAL fac1     ! intermediate scratch variable
+      REAL shprme   ! intermediate specific humidity pert.
+      REAL qsattp   ! saturation mixing ratio for 
+C                   !  thermally perturbed PBL parcels 
+      REAL dz       ! local layer depth
+      REAL b1       ! bouyancy measure in detrainment lvl
+      REAL b2       ! bouyancy measure in condensation lvl
+      REAL g     ! bounded vertical gradient of hb
+      REAL tmass ! total mass available for convective exchange
+      REAL denom ! intermediate scratch variable
+      REAL qtest1! used in negative q test (middle lvl) 
+      REAL qtest2! used in negative q test (lower lvl) 
+      REAL fslkp ! flux lw static energy (bot interface)
+      REAL fslkm ! flux lw static energy (top interface)
+      REAL fqlkp ! flux total water (bottom interface)
+      REAL fqlkm ! flux total water (top interface)
+      REAL botflx! bottom constituent mixing ratio flux
+      REAL topflx! top constituent mixing ratio flux
+      REAL efac1 ! ratio cmrb to convectively induced change (bot lvl)
+      REAL efac2 ! ratio cmrb to convectively induced change (mid lvl)
+      REAL efac3 ! ratio cmrb to convectively induced change (top lvl)
+c
+      INTEGER i,k  ! indices horizontal et vertical
+      INTEGER km1  ! k-1 (index offset)
+      INTEGER kp1  ! k+1 (index offset)
+      INTEGER m    ! constituent index
+      INTEGER ktp  ! temporary index used to track top 
+      INTEGER is   ! nombre de points a ajuster
+C
+      REAL tmp1, tmp2, tmp3, tmp4
+      REAL zx_t, zx_p, zx_q, zx_qs, zx_gam
+      REAL zcor, zdelta, zcvm5
+C
+      REAL qhalf, sh1, sh2, shbs1, shbs2
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      qhalf(sh1,sh2,shbs1,shbs2) = MIN(MAX(sh1,sh2),
+     $                            (shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2))
+C
+C-----------------------------------------------------------------------
+c pas de traceur pour l'instant
+      DO m = 1, pcnst
+      DO k = 1, klev
+      DO i = 1, klon
+         cmrb(i,k,m) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+c
+c Les perturbations de la couche limite sont zero pour l'instant
+c
+      DO m = 1, pcnst
+      DO i = 1, klon
+         cmrp(i,m) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         thtap(i) = 0.0
+         shp(i) = 0.0
+         pblh(i) = 1.0
+      ENDDO
+C
+C Ensure that characteristic adjustment time scale (cmftau) assumed
+C in estimate of eta isn't smaller than model time scale (deltat)
+C
+      dt   = deltat
+      cats = MAX(dt,cmftau)
+      rdt  = 1.0/dt
+C
+C Compute sb,hb,shbs,hbs
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = tb(i,k)
+         zx_p = p(i,k)
+         zx_q = shb(i,k)
+           zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+           zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+           zx_qs=MIN(0.5,zx_qs)
+           zcor=1./(1.-retv*zx_qs)
+           zx_qs=zx_qs*zcor
+           zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+         shbs(i,k) = zx_qs
+         gam(i,k) = zx_gam
+      ENDDO
+      ENDDO
+C
+      DO k=limcnv,klev
+         DO i=1,klon
+            sb (i,k) = RCPD*tb(i,k) + gz(i,k)
+            hb (i,k) = sb(i,k) + RLVTT*shb(i,k)
+            hbs(i,k) = sb(i,k) + RLVTT*shbs(i,k)
+         ENDDO
+      ENDDO
+C
+C Compute sbh, shbh
+C
+      DO k=limcnv+1,klev
+         km1 = k - 1
+         DO i=1,klon
+            sbh (i,k) =0.5*(sb(i,km1) + sb(i,k))
+            shbh(i,k) =qhalf(shb(i,km1),shb(i,k),shbs(i,km1),shbs(i,k))
+            hbh (i,k) =sbh(i,k) + RLVTT*shbh(i,k)
+         ENDDO
+      ENDDO
+C
+C Specify properties at top of model (not used, but filling anyway)
+C
+      DO i=1,klon
+         sbh (i,limcnv) = sb(i,limcnv)
+         shbh(i,limcnv) = shb(i,limcnv)
+         hbh (i,limcnv) = hb(i,limcnv)
+      ENDDO
+C
+C Zero vertically independent control, tendency & diagnostic arrays
+C
+      DO i=1,klon
+         prec(i)  = 0.0
+         dzcld(i) = 0.0
+         cnb(i)   = 0
+         cnt(i)   = klev+1
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1,klon
+         cmfdt(i,k)  = 0.
+         cmfdq(i,k)  = 0.
+         cmfdqr(i,k) = 0.
+         cmfmc(i,k)  = 0.
+         cmfsl(i,k)  = 0.
+         cmflq(i,k)  = 0.
+        ENDDO
+      ENDDO
+C
+C Begin moist convective mass flux adjustment procedure.
+C Formalism ensures that negative cloud liquid water can never occur
+C
+      DO 70 k=klev-1,limcnv+1,-1
+         km1 = k - 1
+         kp1 = k + 1
+         DO 10 i=1,klon
+            eta   (i) = 0.0
+            beta  (i) = 0.0
+            ds1   (i) = 0.0
+            ds2   (i) = 0.0
+            ds3   (i) = 0.0
+            dq1   (i) = 0.0
+            dq2   (i) = 0.0
+            dq3   (i) = 0.0
+C
+C Specification of "cloud base" conditions
+C
+            qprime    = 0.0
+            tprime    = 0.0
+C
+C Assign tprime within the PBL to be proportional to the quantity
+C thtap (which will be bounded by tpmax), passed to this routine by 
+C the PBL routine.  Don't allow perturbation to produce a dry 
+C adiabatically unstable parcel.  Assign qprime within the PBL to be 
+C an appropriately modified value of the quantity shp (which will be 
+C bounded by shpmax) passed to this routine by the PBL routine.  The 
+C quantity qprime should be less than the local saturation value 
+C (qsattp=qsat[t+tprime,p]).  In both cases, thtap and shp are
+C linearly reduced toward zero as the PBL top is approached.
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.0) THEN
+               fac1   = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               tprime = MIN(thtap(i),tpmax)*fac1
+               qsattp = shbs(i,kp1) + RCPD/RLVTT*gam(i,kp1)*tprime
+               shprme = MIN(MIN(shp(i),shpmax)*fac1,
+     $                        MAX(qsattp-shb(i,kp1),0.0))
+               qprime = MAX(qprime,shprme)
+            ELSE
+               tprime = 0.0
+               qprime = 0.0
+            ENDIF
+C
+C Specify "updraft" (in-cloud) thermodynamic properties
+C
+            sc (i)    = sb (i,kp1) + RCPD*tprime
+            shc(i)    = shb(i,kp1) + qprime
+            hc (i)    = sc (i    ) + RLVTT*shc(i)
+            flotab(i) = hc(i) - hbs(i,k)
+            dz        = dp(i,k)*RD*tb(i,k)/RG/p(i,k)
+            IF (flotab(i).gt.0.0) THEN
+               dzcld(i) = dzcld(i) + dz
+            ELSE
+               dzcld(i) = 0.0
+            ENDIF
+   10    CONTINUE
+C
+C Check on moist convective instability
+C
+         is = 0
+         DO i = 1, klon
+            IF (flotab(i).GT.0.0) THEN
+               ldcum(i) = .TRUE.
+               is = is + 1
+            ELSE
+               ldcum(i) = .FALSE.
+            ENDIF
+         ENDDO
+C
+         IF (is.EQ.0) THEN
+            DO i=1,klon
+               dzcld(i) = 0.0
+            ENDDO
+            GOTO 70
+         ENDIF
+C
+C Current level just below top level => no overshoot
+C
+         IF (k.le.limcnv+1) THEN
+            DO i=1,klon
+            IF (ldcum(i)) THEN
+               cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+               cldwtr(i) = MAX(0.0,cldwtr(i))
+               beta(i)   = 0.0
+            ENDIF
+            ENDDO
+            GOTO 20
+         ENDIF
+C
+C First guess at overshoot parameter using crude buoyancy closure
+C 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
+C If pre-existing supersaturation in detrainment layer, beta=0
+C cldwtr is temporarily equal to RLVTT*l (l=> liquid water)
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+            cldwtr(i) = MAX(0.0,cldwtr(i))
+            betamx = 1.0 - c0*MAX(0.0,(dzcld(i)-dzmin))
+            b1        = (hc(i) - hbs(i,km1))*dp(i,km1)
+            b2        = (hc(i) - hbs(i,k  ))*dp(i,k  )
+            beta(i)   = MAX(betamn,MIN(betamx, 1.0+b1/b2))
+            IF (hbs(i,km1).le.hb(i,km1)) beta(i) = 0.0
+         ENDIF
+         ENDDO
+C
+C Bound maximum beta to ensure physically realistic solutions
+C
+C First check constrains beta so that eta remains positive
+C (assuming that eta is already positive for beta equal zero)
+c La premiere contrainte de beta est que le flux eta doit etre positif.
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.99*(tmp1/tmp2)
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+C
+C Second check involves supersaturation of "detrainment layer"
+C small amount of supersaturation acceptable (by ssfac factor)
+c La 2e contrainte est que la convection ne doit pas sursaturer
+c la "detrainment layer", Neanmoins, une petite sursaturation
+c est acceptee (facteur ssfac).
+C
+            IF (hb(i,km1).lt.hbs(i,km1)) THEN
+               tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $               - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+               tmp1 = tmp1/dp(i,k)
+               tmp2 = gam(i,km1)*(sbh(i,k)-sc(i) + cldwtr(i)) -
+     $                 hbh(i,k) + hc(i) - sc(i) + sbh(i,k)
+               tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+               tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2
+     $               / (dp(i,km1)*(hbs(i,km1)-hb(i,km1))) + tmp3
+               IF ((beta(i)*tmp4-tmp1).GT.0.0) THEN
+                  betamx = ssfac*(tmp1/tmp4)
+                  beta(i)   = MAX(0.0,MIN(betamx,beta(i)))
+               ENDIF
+            ELSE 
+               beta(i) = 0.0
+            ENDIF
+C
+C Third check to avoid introducing 2 delta x thermodynamic
+C noise in the vertical ... constrain adjusted h (or theta e)
+C so that the adjustment doesn't contribute to "kinks" in h
+C
+            g = MIN(0.0,hb(i,k)-hb(i,km1))
+            tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt) / (hc(i)-hbs(i,k))
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp1 = tmp1/dp(i,k)
+            tmp1 = tmp3*tmp1 + (hc(i) - hbh(i,kp1))/dp(i,k)
+            tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+     $            + (hc(i)-hbh(i,k)-cldwtr(i))
+     $             *(1.0/dp(i,k)+1.0/dp(i,kp1))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.0
+               IF (tmp2.NE.0.0) betamx = tmp1/tmp2
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C Calculate mass flux required for stabilization.
+C
+C Ensure that the convective mass flux, eta, is positive by
+C setting negative values of eta to zero..
+C Ensure that estimated mass flux cannot move more than the
+C minimum of total mass contained in either layer k or layer k+1.
+C Also test for other pathological cases that result in non-
+C physical states and adjust eta accordingly.
+C
+   20    CONTINUE
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            beta(i) = MAX(0.0,beta(i))
+            tmp1 = hc(i) - hbs(i,k)
+            tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) -
+     $               beta(i)*(1.0+gam(i,k))*(sc(i)-sbh(i,k)))/dp(i,k) -
+     $              (hbh(i,kp1)-hc(i))/dp(i,kp1)
+            eta(i) = tmp1/(tmp2*RG*cats)
+            tmass = MIN(dp(i,k),dp(i,kp1))/RG
+            IF (eta(i).GT.tmass*rdt .OR. eta(i).LE.0.0) eta(i) = 0.0
+C
+C Check on negative q in top layer (bound beta)
+C
+            IF(shc(i)-shbh(i,k).LT.0.0 .AND. beta(i)*eta(i).NE.0.0)THEN
+               denom = eta(i)*RG*dt*(shc(i) - shbh(i,k))/dp(i,km1)
+               beta(i) = MAX(0.0,MIN(-0.999*shb(i,km1)/denom,beta(i)))
+            ENDIF
+C
+C Check on negative q in middle layer (zero eta)
+C
+            qtest1 = shb(i,k) + eta(i)*RG*dt*((shc(i) - shbh(i,kp1)) -
+     $               (1.0 - beta(i))*cldwtr(i)/RLVTT -
+     $               beta(i)*(shc(i) - shbh(i,k)))/dp(i,k)
+            IF (qtest1.le.0.0) eta(i) = 0.0
+C
+C Check on negative q in lower layer (bound eta)
+C
+            fac1 = -(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            qtest2 = shb(i,kp1) - eta(i)*RG*dt*fac1
+            IF (qtest2 .lt. 0.0) THEN
+               eta(i) = 0.99*shb(i,kp1)/(RG*dt*fac1)
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C
+C Calculate cloud water, rain water, and thermodynamic changes
+C
+         DO 30 i=1,klon
+         IF (ldcum(i)) THEN
+            etagdt = eta(i)*RG*dt
+            cldwtr(i) = etagdt*cldwtr(i)/RLVTT/RG
+            rnwtr(i) = (1.0 - beta(i))*cldwtr(i)
+            ds1(i) = etagdt*(sbh(i,kp1) - sc(i))/dp(i,kp1)
+            dq1(i) = etagdt*(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            ds2(i) = (etagdt*(sc(i) - sbh(i,kp1)) +
+     $                RLVTT*RG*cldwtr(i) - beta(i)*etagdt*
+     $                (sc(i) - sbh(i,k)))/dp(i,k)
+            dq2(i) = (etagdt*(shc(i) - shbh(i,kp1)) -
+     $                RG*rnwtr(i) - beta(i)*etagdt*
+     $                (shc(i) - shbh(i,k)))/dp(i,k)
+            ds3(i) = beta(i)*(etagdt*(sc(i) - sbh(i,k)) -
+     $               RLVTT*RG*cldwtr(i))/dp(i,km1)
+            dq3(i) = beta(i)*etagdt*(shc(i) - shbh(i,k))/dp(i,km1)
+C
+C Isolate convective fluxes for later diagnostics
+C
+            fslkp = eta(i)*(sc(i) - sbh(i,kp1))
+            fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) -
+     $                       RLVTT*cldwtr(i)*rdt)
+            fqlkp = eta(i)*(shc(i) - shbh(i,kp1))
+            fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k))
+C
+C
+C Update thermodynamic profile (update sb, hb, & hbs later)
+C
+            tb (i,kp1) = tb(i,kp1)  + ds1(i) / RCPD
+            tb (i,k  ) = tb(i,k  )  + ds2(i) / RCPD
+            tb (i,km1) = tb(i,km1)  + ds3(i) / RCPD
+            shb(i,kp1) = shb(i,kp1) + dq1(i)
+            shb(i,k  ) = shb(i,k  ) + dq2(i)
+            shb(i,km1) = shb(i,km1) + dq3(i)
+            prec(i)    = prec(i)    + rnwtr(i)/rhoh2o
+C
+C Update diagnostic information for final budget
+C Tracking temperature & specific humidity tendencies,
+C rainout term, convective mass flux, convective liquid
+C water static energy flux, and convective total water flux
+C
+            cmfdt (i,kp1) = cmfdt (i,kp1) + ds1(i)/RCPD*rdt
+            cmfdt (i,k  ) = cmfdt (i,k  ) + ds2(i)/RCPD*rdt
+            cmfdt (i,km1) = cmfdt (i,km1) + ds3(i)/RCPD*rdt
+            cmfdq (i,kp1) = cmfdq (i,kp1) + dq1(i)*rdt
+            cmfdq (i,k  ) = cmfdq (i,k  ) + dq2(i)*rdt
+            cmfdq (i,km1) = cmfdq (i,km1) + dq3(i)*rdt
+            cmfdqr(i,k  ) = cmfdqr(i,k  ) + (RG*rnwtr(i)/dp(i,k))*rdt
+            cmfmc (i,kp1) = cmfmc (i,kp1) + eta(i)
+            cmfmc (i,k  ) = cmfmc (i,k  ) + beta(i)*eta(i)
+            cmfsl (i,kp1) = cmfsl (i,kp1) + fslkp
+            cmfsl (i,k  ) = cmfsl (i,k  ) + fslkm
+            cmflq (i,kp1) = cmflq (i,kp1) + RLVTT*fqlkp
+            cmflq (i,k  ) = cmflq (i,k  ) + RLVTT*fqlkm
+            qc    (i,k  ) =                (RG*rnwtr(i)/dp(i,k))*rdt
+         ENDIF
+   30    CONTINUE
+C
+C Next, convectively modify passive constituents
+C
+         DO 50 m=1,pcnst
+         DO 40 i=1,klon
+         IF (ldcum(i)) THEN
+C
+C If any of the reported values of the constituent is negative in
+C the three adjacent levels, nothing will be done to the profile
+C
+            IF ((cmrb(i,kp1,m).LT.0.0) .OR.
+     $          (cmrb(i,k,m).LT.0.0) .OR.
+     $          (cmrb(i,km1,m).LT.0.0)) GOTO 40
+C
+C Specify constituent interface values (linear interpolation)
+C
+            cmrh(i,k  ) = 0.5*(cmrb(i,km1,m) + cmrb(i,k  ,m))
+            cmrh(i,kp1) = 0.5*(cmrb(i,k  ,m) + cmrb(i,kp1,m))
+C
+C Specify perturbation properties of constituents in PBL
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.) THEN
+               fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               cmrc(i) = cmrb(i,kp1,m) + cmrp(i,m)*fac1
+            ELSE
+               cmrc(i) = cmrb(i,kp1,m)
+            ENDIF
+C
+C Determine fluxes, flux divergence => changes due to convection
+C Logic must be included to avoid producing negative values. A bit
+C messy since there are no a priori assumptions about profiles.
+C Tendency is modified (reduced) when pending disaster detected.
+C
+            etagdt = eta(i)*RG*dt
+            botflx   = etagdt*(cmrc(i) - cmrh(i,kp1))
+            topflx   = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
+            dcmr1(i) = -botflx/dp(i,kp1)
+            efac1    = 1.0
+            efac2    = 1.0
+            efac3    = 1.0
+C
+            IF (cmrb(i,kp1,m)+dcmr1(i) .LT. 0.0) THEN
+               efac1 = MAX(tiny,ABS(cmrb(i,kp1,m)/dcmr1(i)) - eps)
+            ENDIF
+C
+            IF (efac1.EQ.tiny .OR. efac1.GT.1.0) efac1 = 0.0
+            dcmr1(i) = -efac1*botflx/dp(i,kp1)
+            dcmr2(i) = (efac1*botflx - topflx)/dp(i,k)
+C  
+            IF (cmrb(i,k,m)+dcmr2(i) .LT. 0.0) THEN
+               efac2 = MAX(tiny,ABS(cmrb(i,k  ,m)/dcmr2(i)) - eps)
+            ENDIF
+C
+            IF (efac2.EQ.tiny .OR. efac2.GT.1.0) efac2 = 0.0
+            dcmr2(i) = (efac1*botflx - efac2*topflx)/dp(i,k)
+            dcmr3(i) = efac2*topflx/dp(i,km1)
+C
+            IF (cmrb(i,km1,m)+dcmr3(i) .LT. 0.0) THEN
+               efac3 = MAX(tiny,ABS(cmrb(i,km1,m)/dcmr3(i)) - eps)
+            ENDIF
+C
+            IF (efac3.EQ.tiny .OR. efac3.GT.1.0) efac3 = 0.0
+            efac3    = MIN(efac2,efac3)
+            dcmr2(i) = (efac1*botflx - efac3*topflx)/dp(i,k)
+            dcmr3(i) = efac3*topflx/dp(i,km1)
+C
+            cmrb(i,kp1,m) = cmrb(i,kp1,m) + dcmr1(i)
+            cmrb(i,k  ,m) = cmrb(i,k  ,m) + dcmr2(i)
+            cmrb(i,km1,m) = cmrb(i,km1,m) + dcmr3(i)
+         ENDIF
+   40    CONTINUE
+   50    CONTINUE              ! end of m=1,pcnst loop
+C
+         IF (k.EQ.limcnv+1) GOTO 60 ! on ne pourra plus glisser
+c
+c Dans la procedure de glissage ascendant, les variables thermo-
+c dynamiques des couches k et km1 servent au calcul des couches
+c superieures. Elles ont donc besoin d'une mise-a-jour.
+C
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            zx_t = tb(i,k)
+            zx_p = p(i,k)
+            zx_q = shb(i,k)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,k) = zx_qs
+            gam(i,k) = zx_gam
+c
+            zx_t = tb(i,km1)
+            zx_p = p(i,km1)
+            zx_q = shb(i,km1)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,km1) = zx_qs
+            gam(i,km1) = zx_gam
+C
+            sb (i,k  ) = sb(i,k  ) + ds2(i)
+            sb (i,km1) = sb(i,km1) + ds3(i)
+            hb (i,k  ) = sb(i,k  ) + RLVTT*shb(i,k)
+            hb (i,km1) = sb(i,km1) + RLVTT*shb(i,km1)
+            hbs(i,k  ) = sb(i,k  ) + RLVTT*shbs(i,k  )
+            hbs(i,km1) = sb(i,km1) + RLVTT*shbs(i,km1)
+C
+            sbh (i,k) = 0.5*(sb(i,k) + sb(i,km1))
+            shbh(i,k) = qhalf(shb(i,km1),shb(i,k)
+     $                       ,shbs(i,km1),shbs(i,k))
+            hbh (i,k) = sbh(i,k) + RLVTT*shbh(i,k)
+            sbh (i,km1) = 0.5*(sb(i,km1) + sb(i,k-2))
+            shbh(i,km1) = qhalf(shb(i,k-2),shb(i,km1),
+     $                    shbs(i,k-2),shbs(i,km1))
+            hbh (i,km1) = sbh(i,km1) + RLVTT*shbh(i,km1)
+         ENDIF
+         ENDDO
+C
+C Ensure that dzcld is reset if convective mass flux zero
+C specify the current vertical extent of the convective activity
+C top of convective layer determined by size of overshoot param.
+C
+   60    CONTINUE
+         DO i=1,klon
+            etagt0 = eta(i).gt.0.0
+            IF (.not.etagt0) dzcld(i) = 0.0
+            IF (etagt0 .and. beta(i).gt.betamn) THEN
+               ktp = km1
+            ELSE
+               ktp = k
+            ENDIF
+            IF (etagt0) THEN
+               cnt(i) = MIN(cnt(i),ktp)
+               cnb(i) = MAX(cnb(i),k)
+            ENDIF
+         ENDDO
+   70 CONTINUE        ! end of k loop
+C
+C determine whether precipitation, prec, is frozen (snow) or not
+C
+      DO i=1,klon
+         IF (tb(i,klev).LT.tmelt .AND. tb(i,klev-1).lt.tmelt) THEN
+             cmfprs(i) = prec(i)*rdt
+         ELSE
+             cmfprt(i) = prec(i)*rdt
+         ENDIF
+      ENDDO
+C
+      RETURN  ! we're all done ... return to calling procedure
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/concvl.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/concvl.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/concvl.F	(revision 984)
@@ -0,0 +1,198 @@
+!
+! $Header$
+!
+      SUBROUTINE concvl (iflag_con,dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcondc,wd,
+     .             pmflxr,pmflxs,
+     .             da,phi,mp)
+ 
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Cape----output-R-CAPE (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       INTEGER iflag_con
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev)
+       REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev),cape(klon),tvp(klon,klev)
+       real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+       REAL qcondc(klon,klev)
+       REAL wd(klon)
+c
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev)
+cym       REAL cbmf(klon)
+cym       SAVE cbmf
+       REAL,ALLOCATABLE,SAVE :: cbmf(:)
+c$OMP THREADPRIVATE(cbmf)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c
+cym
+      snow(:)=0
+      
+      IF (ifrst .EQ. 0) THEN
+         ifrst = 1
+	 allocate(cbmf(klon))
+         DO i = 1, klon
+          cbmf(i) = 0.
+         ENDDO
+      ENDIF
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+         pmflxs(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+
+c
+      if (iflag_con .eq. 4) then
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+      else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs(i,k)=zx_qs
+        ENDDO
+      ENDDO
+      endif ! iflag_con
+c
+C------------------------------------------------------------------
+
+C Main driver for convection:
+C		iflag_con = 3  -> equivalent to convect3
+C		iflag_con = 4  -> equivalent to convect1/2
+
+      CALL cv_driver(klon,klev,klev+1,ntra,iflag_con,
+     :              t,q,qs,u,v,tra,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,d_tra,rain,
+     $              pmflxr,cbmf,work1,work2,
+     $              kbas,ktop,
+     $              dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape,
+     $              da,phi,mp)
+
+C------------------------------------------------------------------
+
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+      ENDDO
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO
+c les traceurs ne sont pas mis dans cette version de convect4:
+      if (iflag_con.eq.4) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+         ENDDO
+        ENDDO
+       ENDDO
+      endif
+ 
+      RETURN
+      END
+ 
Index: LMDZ4/tags/LF_20080728/libf/phytherm/condsurf.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/condsurf.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/condsurf.F	(revision 984)
@@ -0,0 +1,139 @@
+c $Header$
+c
+      SUBROUTINE condsurf( jour, jourvrai, lmt_bils )
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+c
+c I. Musat 05.2005
+c
+c Lire chaque jour le bilan de chaleur au sol issu 
+c d'un run atmospherique afin de l'utiliser dans
+c dans un run "slab" ocean 
+c -----------------------------------------
+c jour     : input  , numero du jour a lire
+c jourvrai : input  , vrai jour de la simulation  
+c
+c lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean")
+c
+#include "netcdf.inc"
+      INTEGER nid, nvarid
+      INTEGER debut(2)
+      INTEGER epais(2)
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+#include "temps.h"
+#include "clesphys.h"
+c
+      INTEGER     nannemax
+      PARAMETER ( nannemax = 60 )
+c
+      INTEGER jour, jourvrai
+      REAL lmt_bils(klon) !bilan chaleur au sol
+c
+c Variables locales:
+      INTEGER ig, i, kt, ierr
+      LOGICAL ok
+      INTEGER anneelim,anneemax
+      CHARACTER*20 fich
+      
+      REAL :: lmt_bils_glo(klon_glo)
+      
+cc
+cc   .....................................................................
+cc
+cc    Pour lire le fichier limit correspondant vraiment  a l'annee de la
+cc     simulation en cours , il suffit de mettre  ok_limitvrai = .TRUE.
+cc
+cc   ......................................................................
+c
+c
+      
+      IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
+         PRINT*,'Le jour demande n est pas correct: ', jour
+         CALL ABORT
+      ENDIF
+c
+       anneelim  = annee_ref
+       anneemax  = annee_ref + nannemax
+c
+c
+       IF( ok_limitvrai )       THEN
+          DO  kt = 1, nannemax
+           IF(jourvrai.LE. (kt-1)*360 + 359  )  THEN
+              WRITE(fich,'("limit",i4,".nc")') anneelim
+c             PRINT *,' Fichier  Limite ',fich
+              GO TO 100
+             ENDIF
+           anneelim = anneelim + 1
+          ENDDO
+
+         PRINT *,' PBS ! Le jour a lire sur le fichier limit ne se '
+         PRINT *,' trouve pas sur les ',nannemax,' annees a partir de '
+         PRINT *,' l annee de debut', annee_ref
+         CALL EXIT(1)
+c
+100     CONTINUE
+c
+       ELSE
+     
+            WRITE(fich,'("limitNEW.nc")') 
+c           PRINT *,' Fichier  Limite ',fich
+       ENDIF
+c
+c Ouvrir le fichier en format NetCDF:
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        WRITE(6,*)' Pb d''ouverture du fichier ', fich
+        WRITE(6,*)' Le fichier limit ',fich,' (avec 4 chiffres , pour' 
+        WRITE(6,*)'       l an 2000 )  ,  n existe  pas !  ' 
+        WRITE(6,*)' ierr = ', ierr
+        CALL EXIT(1)
+      ENDIF
+c     DO k = 1, jour
+c La tranche de donnees a lire:
+c
+      debut(1) = 1
+      debut(2) = jourvrai
+      epais(1) = klon_glo
+      epais(2) = 1
+c Bilan flux de chaleur au sol:
+c
+      ierr = NF_INQ_VARID (nid, "BILS", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <BILS> est absent"
+         CALL abort
+      ENDIF
+      PRINT*,'debut,epais',debut,epais,'jour,jourvrai',jour,jourvrai
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_bils_glo)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_bils_glo)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <BILS>"
+         CALL abort
+      ENDIF
+c     ENDDO !k = 1, jour
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+      
+      ENDIF ! is_mpi_root==0
+
+c$OMP END MASTER
+      CALL scatter(lmt_bils_glo,lmt_bils)
+            
+c
+c
+c     PRINT*, 'lmt_bils est lu pour jour: ', jour
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conema3.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conema3.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conema3.F	(revision 984)
@@ -0,0 +1,421 @@
+!
+! $Header$
+!
+      SUBROUTINE conema3 (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,bas,top,Ma,cape,tvp,rflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcond_incld)
+
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c Mai 1998: Interface modifiee pour implementation dans LMDZ
+c======================================================================
+c Arguments:
+c dtime---input-R-pas d'integration (s)
+c paprs---input-R-pression inter-couches (Pa)
+c pplay---input-R-pression au milieu des couches (Pa)
+c t-------input-R-temperature (K)
+c q-------input-R-humidite specifique (kg/kg)
+c u-------input-R-vitesse du vent zonal (m/s)
+c v-------input-R-vitesse duvent meridien (m/s)
+c tra-----input-R-tableau de rapport de melange des traceurs
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c
+C d_t-----output-R-increment de la temperature
+c d_q-----output-R-increment de la vapeur d'eau
+c d_u-----output-R-increment de la vitesse zonale
+c d_v-----output-R-increment de la vitesse meridienne
+c d_tra---output-R-increment du contenu en traceurs
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c kbas----output-R-bas du nuage (integer)
+c ktop----output-R-haut du nuage (integer)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c bas-----output-R-bas du nuage (real)
+c top-----output-R-haut du nuage (real)
+c Ma------output-R-flux ascendant non dilue (kg/m**2/s)
+c cape----output-R-CAPE
+c tvp-----output-R-virtual temperature of the lifted parcel
+c rflag---output-R-flag sur le fonctionnement de convect
+c pbase---output-R-pression a la base du nuage (Pa)
+c bbase---output-R-buoyancy a la base du nuage (K)
+c dtvpdt1-output-R-derivative of parcel virtual temp wrt T1 
+c dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1 
+c dplcldt-output-R-derivative of the PCP pressure wrt T1
+c dplcldr-output-R-derivative of the PCP pressure wrt Q1
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "conema3.h"
+      INTEGER i, l,m,itra
+      INTEGER ntra,ntrac !number of tracers; if no tracer transport
+                         ! is needed, set ntra = 1 (or 0)
+      PARAMETER (ntrac=nqmx-2)
+      REAL dtime
+c
+      REAL d_t2(klon,klev), d_q2(klon,klev) ! sbl
+      REAL d_u2(klon,klev), d_v2(klon,klev) ! sbl
+      REAL em_d_t2(klev), em_d_q2(klev)     ! sbl   
+      REAL em_d_u2(klev), em_d_v2(klev)     ! sbl   
+c 
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), d_t(klon,klev), d_q(klon,klev)
+      REAL u(klon,klev), v(klon,klev), tra(klon,klev,ntra)
+      REAL d_u(klon,klev), d_v(klon,klev), d_tra(klon,klev,ntra)
+      REAL work1(klon,klev), work2(klon,klev)
+      REAL upwd(klon,klev), dnwd(klon,klev), dnwdbis(klon,klev)
+      REAL rain(klon)
+      REAL snow(klon)
+      REAL cape(klon), tvp(klon,klev), rflag(klon)
+      REAL pbase(klon), bbase(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+      INTEGER kbas(klon), ktop(klon)
+
+      REAL wd(klon)
+      REAL qcond_incld(klon,klev)
+c
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+      
+cym      REAL em_t(klev)
+      REAL,ALLOCATABLE,SAVE :: em_t(:)
+c$OMP THREADPRIVATE(em_t)  
+cym      REAL em_q(klev)
+      REAL,ALLOCATABLE,SAVE :: em_q(:)
+c$OMP THREADPRIVATE(em_q) 
+cym      REAL em_qs(klev)
+      REAL,ALLOCATABLE,SAVE :: em_qs(:) 
+c$OMP THREADPRIVATE(em_qs)  
+cym      REAL em_u(klev), em_v(klev), em_tra(klev,ntrac)
+      REAL,ALLOCATABLE,SAVE :: em_u(:),em_v(:),em_tra(:,:)
+c$OMP THREADPRIVATE(em_u,em_v,em_tra)      
+cym      REAL em_ph(klev+1), em_p(klev)
+      REAL,ALLOCATABLE,SAVE ::em_ph(:),em_p(:)
+c$OMP THREADPRIVATE(em_ph,em_p)
+cym      REAL em_work1(klev), em_work2(klev)
+      REAL,ALLOCATABLE,SAVE ::em_work1(:),em_work2(:)
+c$OMP THREADPRIVATE(em_work1,em_work2)      
+cym      REAL em_precip, em_d_t(klev), em_d_q(klev)
+      REAL,SAVE :: em_precip
+c$OMP THREADPRIVATE(em_precip)      
+      REAL,ALLOCATABLE,SAVE :: em_d_t(:),em_d_q(:)
+c$OMP THREADPRIVATE(em_d_t,em_d_q)
+cym      REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac)
+      REAL,ALLOCATABLE,SAVE ::em_d_u(:),em_d_v(:),em_d_tra(:,:)
+c$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra)      
+cym      REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)
+      REAL,ALLOCATABLE,SAVE :: em_upwd(:),em_dnwd(:),em_dnwdbis(:)
+c$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis)
+      REAL em_dtvpdt1(klev), em_dtvpdq1(klev)
+      REAL em_dplcldt, em_dplcldr
+cym      SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2
+cym      SAVE em_u,em_v, em_tra
+cym      SAVE em_d_u,em_d_v, em_d_tra
+cym      SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis
+
+      INTEGER em_bas, em_top
+      SAVE em_bas, em_top
+c$OMP THREADPRIVATE(em_bas,em_top)
+      REAL em_wd
+      REAL em_qcond(klev)
+      REAL em_qcondc(klev)
+c
+      REAL zx_t, zx_qs, zdelta, zcor
+      INTEGER iflag
+      REAL sigsum
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     VARIABLES A SORTIR
+cccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+cym      REAL emmip(klev) !variation de flux ascnon dilue i et i+1
+      REAL,ALLOCATABLE,SAVE ::emmip(:)
+c$OMP THREADPRIVATE(emmip)
+cym      SAVE emmip
+cym      real emMke(klev)
+      REAL,ALLOCATABLE,SAVE ::emMke(:)
+c$OMP THREADPRIVATE(emMke)
+cym      save emMke
+      real top
+      real bas
+cym      real emMa(klev)
+      REAL,ALLOCATABLE,SAVE ::emMa(:)
+c$OMP THREADPRIVATE(emMa)
+cym      save emMa
+      real Ma(klon,klev)
+      real Ment(klev,klev)
+      real Qent(klev,klev)
+      real TPS(klev),TLS(klev)
+      real SIJ(klev,klev)
+      real em_CAPE, em_TVP(klev)
+      real em_pbase, em_bbase
+      integer iw,j,k,ix,iy
+
+c -- sb: pour schema nuages:
+
+       integer iflagcon
+       integer em_ifc(klev)
+     
+       real em_pradj
+       real em_cldf(klev), em_cldq(klev)
+       real em_ftadj(klev), em_fradj(klev)
+
+       integer ifc(klon,klev)
+       real pradj(klon)
+       real cldf(klon,klev), cldq(klon,klev)
+       real ftadj(klon,klev), fqadj(klon,klev)
+
+c sb --
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+     
+      if (first) then
+  
+        allocate(em_t(klev))
+        allocate(em_q(klev))
+        allocate(em_qs(klev))
+        allocate(em_u(klev), em_v(klev), em_tra(klev,ntrac))
+        allocate(em_ph(klev+1), em_p(klev))
+        allocate(em_work1(klev), em_work2(klev))
+        allocate(em_d_t(klev), em_d_q(klev))
+        allocate(em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac))
+        allocate(em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev))
+        allocate(emmip(klev)) 
+	allocate(emMke(klev))
+        allocate(emMa(klev))
+  
+        first=.false.
+      endif
+  
+      qcond_incld(:,:) = 0.
+c
+c@$$      print*,'debut conema'
+
+      DO 999 i = 1, klon
+      DO l = 1, klev+1
+         em_ph(l) = paprs(i,l) / 100.0
+      ENDDO
+c
+      DO l = 1, klev
+         em_p(l) = pplay(i,l) / 100.0
+         em_t(l) = t(i,l)
+         em_q(l) = q(i,l)
+         em_u(l) = u(i,l)
+         em_v(l) = v(i,l)
+         do itra = 1, ntra
+          em_tra(l,itra) = tra(i,l,itra)
+         enddo
+c@$$      print*,'em_t',em_t
+c@$$      print*,'em_q',em_q
+c@$$      print*,'em_qs',em_qs
+c@$$      print*,'em_u',em_u
+c@$$      print*,'em_v',em_v
+c@$$      print*,'em_tra',em_tra
+c@$$      print*,'em_p',em_p
+
+ 
+c
+         zx_t = em_t(l)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(l)/100.0
+         zx_qs=MIN(0.5,zx_qs)
+c@$$       print*,'zx_qs',zx_qs
+         zcor=1./(1.-retv*zx_qs) 
+         zx_qs=zx_qs*zcor
+         em_qs(l) = zx_qs
+c@$$      print*,'em_qs',em_qs
+c
+         em_work1(l) = work1(i,l)
+         em_work2(l) = work2(i,l)
+         emMke(l)=0
+c        emMa(l)=0
+c        Ma(i,l)=0
+     
+         em_dtvpdt1(l) = 0.
+         em_dtvpdq1(l) = 0.
+         dtvpdt1(i,l) = 0.
+         dtvpdq1(i,l) = 0.
+      ENDDO
+c
+      em_dplcldt = 0.
+      em_dplcldr = 0.
+      rain(i) = 0.0
+      snow(i) = 0.0
+      kbas(i) = 1
+      ktop(i) = 1
+c ajout SB:
+      bas = 1
+      top = 1
+ 
+ 
+c sb3d      write(*,1792) (em_work1(m),m=1,klev)
+1792  format('sig avant convect ',/,10(1X,E13.5))
+c
+c sb d      write(*,1793) (em_work2(m),m=1,klev)
+1793  format('w avant convect ',/,10(1X,E13.5))
+ 
+c@$$      print*,'avant convect' 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c 
+
+c     print*,'avant convect i=',i
+      CALL convect3(dtime,epmax,ok_adj_ema,
+     .              em_t, em_q, em_qs,em_u ,em_v ,
+     .              em_tra, em_p, em_ph,
+     .              klev, klev+1, klev-1,ntra, dtime, iflag,
+     .              em_d_t, em_d_q,em_d_u,em_d_v,
+     .              em_d_tra, em_precip,
+     .              em_bas, em_top,em_upwd, em_dnwd, em_dnwdbis,
+     .              em_work1, em_work2,emmip,emMke,emMa,Ment,
+     .  Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase,
+     .  em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr, ! sbl
+     .  em_d_t2,em_d_q2,em_d_u2,em_d_v2,em_wd,em_qcond,em_qcondc)!sbl
+c     print*,'apres convect '
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c -- sb: Appel schema statistique de nuages couple a la convection
+c (Bony et Emanuel 2001):
+
+c -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ:
+
+        iflagcon = 3
+c       CALL cv_thermo(iflagcon)
+
+c -- appel schema de nuages:
+
+c       CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t
+c    i          ,em_p,em_ph,dtime,em_qcondc
+c    o          ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc)
+
+        do k = 1, klev 
+         cldf(i,k)  = em_cldf(k)  ! cloud fraction (0-1)
+         cldq(i,k)  = em_cldq(k)  ! in-cloud water content (kg/kg)
+         ftadj(i,k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s)
+         fqadj(i,k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s)
+         ifc(i,k)   = em_ifc(k)   ! flag convergence clouds_gno (1 ou 2)
+        enddo
+        pradj(i) = em_pradj       ! precip from LS supersat adj (mm/day)
+
+c sb --
+c
+c SB:
+      if (iflag.ne.1 .and. iflag.ne.4) then
+         em_CAPE = 0.
+      do l = 1, klev
+         em_upwd(l) = 0.
+         em_dnwd(l) = 0.
+         em_dnwdbis(l) = 0.
+         emMa(l) = 0.
+         em_TVP(l) = 0.
+      enddo
+      endif
+c fin SB
+c
+c  If sig has been set to zero, then set Ma to zero
+c
+      sigsum = 0.
+      do k = 1,klev
+        sigsum = sigsum + em_work1(k)
+      enddo
+      if (sigsum .eq. 0.0) then
+        do k = 1,klev
+          emMa(k) = 0.
+        enddo
+      endif
+c
+c sb3d       print*,'i, iflag=',i,iflag
+c 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c       SORTIE DES ICB ET INB
+c       en fait inb et icb correspondent au niveau ou se trouve
+c       le nuage,le numero d'interface
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+c modif SB:
+      if (iflag.EQ.1 .or. iflag.EQ.4) then
+       top=em_top
+       bas=em_bas
+       kbas(i) = em_bas
+       ktop(i) = em_top
+      endif
+ 
+      pbase(i) = em_pbase
+      bbase(i) = em_bbase
+      rain(i) = em_precip/ 86400.0
+      snow(i) = 0.0
+      cape(i) = em_CAPE
+      wd(i) = em_wd
+      rflag(i) = float(iflag)
+c SB      kbas(i) = em_bas
+c SB      ktop(i) = em_top
+      dplcldt(i) = em_dplcldt
+      dplcldr(i) = em_dplcldr
+      DO l = 1, klev
+         d_t2(i,l) = dtime * em_d_t2(l) 
+         d_q2(i,l) = dtime * em_d_q2(l)
+         d_u2(i,l) = dtime * em_d_u2(l)
+         d_v2(i,l) = dtime * em_d_v2(l)
+
+         d_t(i,l) = dtime * em_d_t(l) 
+         d_q(i,l) = dtime * em_d_q(l)
+         d_u(i,l) = dtime * em_d_u(l)
+         d_v(i,l) = dtime * em_d_v(l)
+         do itra = 1, ntra
+         d_tra(i,l,itra) = dtime * em_d_tra(l,itra)
+         enddo
+         upwd(i,l) = em_upwd(l)
+         dnwd(i,l) = em_dnwd(l)
+         dnwdbis(i,l) = em_dnwdbis(l)
+         work1(i,l) = em_work1(l)
+         work2(i,l) = em_work2(l)
+         Ma(i,l)=emMa(l)
+         tvp(i,l)=em_TVP(l)
+         dtvpdt1(i,l) = em_dtvpdt1(l)
+         dtvpdq1(i,l) = em_dtvpdq1(l)
+
+         if (iflag_clw.eq.0) then
+            qcond_incld(i,l) = em_qcondc(l)
+         else if (iflag_clw.eq.1) then
+            qcond_incld(i,l) = em_qcond(l)
+         endif
+      ENDDO
+  999 CONTINUE
+
+c   On calcule une eau liquide diagnostique en fonction de la 
+c  precip.
+      if ( iflag_clw.eq.2 ) then
+      do l=1,klev
+         do i=1,klon
+            if (ktop(i)-kbas(i).gt.0.and.
+     s         l.ge.kbas(i).and.l.le.ktop(i)) then
+               qcond_incld(i,l)=rain(i)*8.e4
+c    s         *(pplay(i,l      )-paprs(i,ktop(i)+1))
+     s         /(pplay(i,kbas(i))-pplay(i,ktop(i)))
+c    s         **2
+            else
+               qcond_incld(i,l)=0.
+            endif
+         enddo
+         print*,'l=',l,',   qcond_incld=',qcond_incld(1,l)
+      enddo
+      endif
+ 
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conema3.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conema3.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conema3.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+      real epmax             ! 0.993
+      logical ok_adj_ema      ! F
+      integer iflag_clw      ! 0
+
+      common/comconema/epmax,ok_adj_ema,iflag_clw
+!$OMP THREADPRIVATE(/comconema/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conemav.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conemav.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conemav.F	(revision 984)
@@ -0,0 +1,155 @@
+!
+! $Header$
+!
+      SUBROUTINE conemav (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+ 
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Cape----output-R-CAPE (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c======================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev),cape(klon),tvp(klon,klev)
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+c
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev)
+cym       REAL cbmf(klon)
+cym       SAVE cbmf
+       REAL,ALLOCATABLE,SAVE :: cbmf(:)
+c$OMP THREADPRIVATE(cbmf)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c
+      IF (ifrst .EQ. 0) THEN
+         ifrst = 1
+	 allocate(cbmf(klon))
+         DO i = 1, klon
+          cbmf(i) = 0.
+         ENDDO
+      ENDIF
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+
+c
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+c
+      noff = 2
+      minorig = 2
+      CALL convect1(klon,klev,klev+1,noff,minorig,t,q,qs,u,v,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,rain,cbmf,dtime,Ma)
+c
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+c      call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION   ')
+c     if (klon.eq.1) then
+c        print*,'IFLAG ',iflag
+c     else
+c        write(*,'(96i1)') (iflag(i),i=2,klon-1)
+c     endif
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+        DO itra = 1,ntra
+          DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+          ENDDO
+        ENDDO
+      ENDDO
+ 
+c
+c
+c
+      RETURN
+      END
+ 
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conf_phys.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conf_phys.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conf_phys.F90	(revision 984)
@@ -0,0 +1,994 @@
+!
+! $Header$
+!
+!
+!
+
+  subroutine conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, ok_instan, ok_hf, &
+ &                     seuil_inversion, &
+ &                     fact_cldcon, facttemps,ok_newmicro,iflag_cldcon, &
+ &                     iflag_ratqs,ratqsbas,ratqshaut, &
+ &		       ok_ade, ok_aie, &
+ &                     bl95_b0, bl95_b1,&
+ &                     iflag_thermals,nsplit_thermals)
+
+   use IOIPSL
+   implicit none
+
+ include "conema3.h"
+ include "fisrtilp.h"
+ include "nuage.h"
+ include "YOMCST.h"
+!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
+include "clesphys.h"
+include "compbl.h"
+include "control.h"
+!
+! Configuration de la "physique" de LMDZ a l'aide de la fonction
+! GETIN de IOIPSL
+!
+! LF 05/2001
+!
+
+!
+! ocean:      type d'ocean (force, slab, couple)
+! ok_veget:   type de modele de vegetation
+! ok_journe:  sorties journalieres
+! ok_hf:  sorties haute frequence
+! ok_mensuel: sorties mensuelles
+! ok_instan:  sorties instantanees
+! ok_ade, ok_aie: apply or not aerosol direct and indirect effects
+! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 
+!
+
+
+! Sortie:
+  character (len = 6)  :: ocean
+  logical              :: ok_veget, ok_newmicro
+  logical              :: ok_journe, ok_mensuel, ok_instan, ok_hf
+  LOGICAL              :: ok_ade, ok_aie
+  REAL                 :: bl95_b0, bl95_b1
+  real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut
+  integer              :: iflag_cldcon
+  integer              :: iflag_ratqs
+
+  character (len = 6),SAVE  :: ocean_omp
+  logical,SAVE              :: ok_veget_omp, ok_newmicro_omp
+  logical,SAVE        :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp        
+  LOGICAL,SAVE        :: ok_ade_omp, ok_aie_omp
+  REAL,SAVE           :: bl95_b0_omp, bl95_b1_omp
+  REAL,SAVE           :: freq_ISCCP_omp, ecrit_ISCCP_omp
+  real,SAVE           :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp
+  real,SAVE           :: ratqshaut_omp
+  integer,SAVE        :: iflag_cldcon_omp, ip_ebil_phy_omp
+  integer,SAVE        :: iflag_ratqs_omp
+
+! Local
+  integer              :: numout = 6
+  real                 :: zzz
+
+  real :: seuil_inversion
+  real,save :: seuil_inversion_omp
+
+  integer :: iflag_thermals,nsplit_thermals
+  integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
+
+  REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp,co2_ppm_omp
+  REAL,SAVE :: RCO2_omp,CH4_ppb_omp,RCH4_omp,N2O_ppb_omp,RN2O_omp,CFC11_ppt_omp
+  REAL,SAVE :: RCFC11_omp,CFC12_ppt_omp,RCFC12_omp,epmax_omp
+  LOGICAL,SAVE :: ok_adj_ema_omp
+  INTEGER,SAVE :: iflag_clw_omp
+  REAL,SAVE :: cld_lc_lsc_omp,cld_lc_con_omp,cld_tau_lsc_omp,cld_tau_con_omp
+  REAL,SAVE :: ffallv_lsc_omp, ffallv_con_omp,coef_eva_omp
+  LOGICAL,SAVE :: reevap_ice_omp
+  INTEGER,SAVE :: iflag_pdf_omp
+  REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
+  INTEGER,SAVE :: top_height_omp,overlap_omp
+  REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp
+  LOGICAL,SAVE :: ok_kzmin_omp
+  REAL, SAVE :: fmagic_omp
+  INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp
+  CHARACTER*4, SAVE :: type_run_omp
+  LOGICAL,SAVE :: ok_isccp_omp
+  REAL,SAVE :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp
+  REAL,SAVE :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp
+  REAL,SAVE :: ecrit_tra_omp
+  LOGICAL, SAVE :: ok_slab_sicOBS_omp
+  REAL,SAVE :: cvl_corr_omp
+  LOGICAL,SAVE :: ok_lic_melt_omp
+!
+!
+!
+
+!$OMP MASTER
+!Config Key  = OCEAN 
+!Config Desc = Type d'ocean
+!Config Def  = force
+!Config Help = Type d'ocean utilise: force, slab,couple
+!
+  ocean_omp = 'force '
+  call getin('OCEAN', ocean_omp)
+!
+!Config Key  = VEGET 
+!Config Desc = Type de modele de vegetation
+!Config Def  = .false.
+!Config Help = Type de modele de vegetation utilise
+!
+  ok_veget_omp = .false.
+  call getin('VEGET', ok_veget_omp)
+!
+!Config Key  = OK_journe
+!Config Desc = Pour des sorties journalieres 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histday contenant les sorties
+!              journalieres 
+!
+  ok_journe_omp = .false.
+  call getin('OK_journe', ok_journe_omp)
+!
+!Config Key  = ok_hf
+!Config Desc = Pour des sorties haute frequence
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histhf contenant les sorties
+!              haute frequence ( 3h ou 6h)
+!
+  ok_hf_omp = .false.
+  call getin('ok_hf', ok_hf_omp)
+!
+!Config Key  = OK_mensuel
+!Config Desc = Pour des sorties mensuelles 
+!Config Def  = .true.
+!Config Help = Pour creer le fichier histmth contenant les sorties
+!              mensuelles 
+!
+  ok_mensuel_omp = .true.
+  call getin('OK_mensuel', ok_mensuel_omp)
+!
+!Config Key  = OK_instan
+!Config Desc = Pour des sorties instantanees 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histins contenant les sorties
+!              instantanees 
+!
+  ok_instan_omp = .false.
+  call getin('OK_instan', ok_instan_omp)
+!
+!Config Key  = ok_ade
+!Config Desc = Aerosol direct effect or not?
+!Config Def  = .false.
+!Config Help = Used in radlwsw.F
+!
+  ok_ade_omp = .false.
+  call getin('ok_ade', ok_ade_omp)
+
+!
+!Config Key  = ok_aie
+!Config Desc = Aerosol indirect effect or not?
+!Config Def  = .false.
+!Config Help = Used in nuage.F and radlwsw.F
+!
+  ok_aie_omp = .false.
+  call getin('ok_aie', ok_aie_omp)
+
+!
+!Config Key  = bl95_b0
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b0_omp = 2.
+  call getin('bl95_b0', bl95_b0_omp)
+
+!Config Key  = bl95_b1
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b1_omp = 0.2
+  call getin('bl95_b1', bl95_b1_omp)
+
+!Config Key  = freq_ISCCP
+!Config Desc = Frequence d'appel du simulateur ISCCP en secondes;
+!              par defaut 10800, i.e. 3 heures 
+!Config Def  = 10800.
+!Config Help = Used in ini_histISCCP.h
+!
+  freq_ISCCP_omp = 10800.
+  call getin('freq_ISCCP', freq_ISCCP_omp)
+!
+!Config Key  = ecrit_ISCCP
+!Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours;
+!              par defaut 1., i.e. 1 jour
+!Config Def  = 1.
+!Config Help = Used in ini_histISCCP.h
+!
+!
+  ecrit_ISCCP_omp = 1.
+  call getin('ecrit_ISCCP', ecrit_ISCCP_omp)
+!
+!Config Key  = ip_ebil_phy
+!Config Desc = Niveau de sortie pour les diags bilan d'energie 
+!Config Def  = 0
+!Config Help = 
+!               
+  ip_ebil_phy_omp = 0
+  call getin('ip_ebil_phy', ip_ebil_phy_omp)
+!
+!Config Key  = seuil_inversion
+!Config Desc = Seuil ur dTh pour le choix entre les schemas de CL
+!Config Def  = -0.1
+!Config Help = 
+!               
+  seuil_inversion_omp = -0.1
+  call getin('seuil_inversion', seuil_inversion_omp)
+
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG
+!!
+!Config Key  = R_ecc
+!Config Desc = Excentricite
+!Config Def  = 0.016715
+!Config Help = 
+!               
+!valeur AMIP II
+  R_ecc_omp = 0.016715
+  call getin('R_ecc', R_ecc_omp)
+!!
+!Config Key  = R_peri
+!Config Desc = Equinoxe
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_peri_omp = 102.7
+  call getin('R_peri', R_peri_omp)
+!!
+!Config Key  = R_incl
+!Config Desc = Inclinaison
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_incl_omp = 23.441
+  call getin('R_incl', R_incl_omp)
+!!
+!Config Key  = solaire
+!Config Desc = Constante solaire en W/m2
+!Config Def  = 1365.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  solaire_omp = 1365.
+  call getin('solaire', solaire_omp)
+!!
+!Config Key  = co2_ppm
+!Config Desc = concentration du gaz carbonique en ppmv
+!Config Def  = 348.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  co2_ppm_omp = 348.
+  call getin('co2_ppm', co2_ppm_omp)
+!!
+!Config Key  = RCO2
+!Config Desc = Concentration du CO2
+!Config Def  = co2_ppm * 1.0e-06  * 44.011/28.97
+!Config Def  = 348. * 1.0e-06  * 44.011/28.97
+!Config Help = 
+!               
+! RCO2 = 5.286789092164308E-04
+!ancienne valeur
+  RCO2_omp = co2_ppm_omp * 1.0e-06  * 44.011/28.97 ! pour co2_ppm=348.
+
+!!  call getin('RCO2', RCO2)
+!!
+!Config Key  = RCH4
+!Config Desc = Concentration du CH4
+!Config Def  = 1.65E-06* 16.043/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RCH4 = 1.65E-06* 16.043/28.97
+! RCH4 = 9.137366240938903E-07
+!
+!ancienne valeur
+! RCH4 = 1.72E-06* 16.043/28.97
+!OK call getin('RCH4', RCH4)
+  zzz = 1650.
+  call getin('CH4_ppb', zzz)
+  CH4_ppb_omp = zzz
+  RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97
+!!
+!Config Key  = RN2O
+!Config Desc = Concentration du N2O
+!Config Def  = 306.E-09* 44.013/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RN2O = 306.E-09* 44.013/28.97
+! RN2O = 4.648939592682085E-07
+!
+!ancienne valeur
+! RN2O = 310.E-09* 44.013/28.97
+!OK  call getin('RN2O', RN2O)
+  zzz=306.
+  call getin('N2O_ppb', zzz)
+  N2O_ppb_omp = zzz
+  RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97
+!!
+!Config Key  = RCFC11
+!Config Desc = Concentration du CFC11
+!Config Def  = 280.E-12* 137.3686/28.97
+!Config Help = 
+!               
+!
+!OK RCFC11 = 280.E-12* 137.3686/28.97
+  zzz = 280.
+  call getin('CFC11_ppt',zzz)
+  CFC11_ppt_omp = zzz
+  RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97
+! RCFC11 = 1.327690990680013E-09
+!OK call getin('RCFC11', RCFC11)
+!!
+!Config Key  = RCFC12
+!Config Desc = Concentration du CFC12
+!Config Def  = 484.E-12* 120.9140/28.97
+!Config Help = 
+!               
+!
+!OK RCFC12 = 484.E-12* 120.9140/28.97
+  zzz = 484.
+  call getin('CFC12_ppt',zzz)
+  CFC12_ppt_omp = zzz
+  RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97
+! RCFC12 = 2.020102726958923E-09
+!OK call getin('RCFC12', RCFC12)
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END
+!!
+!! KE
+!
+
+!Config key  = cvl_corr
+!Config Desc = Facteur multiplication des precip convectives dans KE
+!Config Def  = 1.00
+!Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire
+  cvl_corr_omp = 1.00
+  CALL getin('cvl_corr', cvl_corr_omp)
+
+
+!Config Key  = epmax
+!Config Desc = Efficacite precip
+!Config Def  = 0.993
+!Config Help = 
+!
+  epmax_omp = .993
+  call getin('epmax', epmax_omp)
+!
+!Config Key  = ok_adj_ema
+!Config Desc =  
+!Config Def  = false
+!Config Help = 
+!
+  ok_adj_ema_omp = .false.
+  call getin('ok_adj_ema',ok_adj_ema_omp)
+!
+!Config Key  = iflag_clw
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clw_omp = 0
+  call getin('iflag_clw',iflag_clw_omp)
+!
+!Config Key  = cld_lc_lsc 
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_lsc_omp = 2.6e-4
+  call getin('cld_lc_lsc',cld_lc_lsc_omp)
+!
+!Config Key  = cld_lc_con
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_con_omp = 2.6e-4
+  call getin('cld_lc_con',cld_lc_con_omp)
+!
+!Config Key  = cld_tau_lsc
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_lsc_omp = 3600.
+  call getin('cld_tau_lsc',cld_tau_lsc_omp)
+!
+!Config Key  = cld_tau_con
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_con_omp = 3600.
+  call getin('cld_tau_con',cld_tau_con_omp)
+!
+!Config Key  = ffallv_lsc
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_lsc_omp = 1.
+  call getin('ffallv_lsc',ffallv_lsc_omp)
+!
+!Config Key  = ffallv_con
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_con_omp = 1.
+  call getin('ffallv_con',ffallv_con_omp)
+!
+!Config Key  = coef_eva
+!Config Desc =  
+!Config Def  = 2.e-5
+!Config Help = 
+!
+  coef_eva_omp = 2.e-5
+  call getin('coef_eva',coef_eva_omp)
+!
+!Config Key  = reevap_ice
+!Config Desc =  
+!Config Def  = .false.
+!Config Help = 
+!
+  reevap_ice_omp = .false.
+  call getin('reevap_ice',reevap_ice_omp)
+
+!Config Key  = iflag_ratqs
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_ratqs_omp = 1
+  call getin('iflag_ratqs',iflag_ratqs_omp)
+
+!
+!Config Key  = iflag_cldcon 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_cldcon_omp = 1
+  call getin('iflag_cldcon',iflag_cldcon_omp)
+
+!
+!Config Key  = iflag_pdf 
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_pdf_omp = 0
+  call getin('iflag_pdf',iflag_pdf_omp)
+!
+!Config Key  = fact_cldcon
+!Config Desc =  
+!Config Def  = 0.375
+!Config Help = 
+!
+  fact_cldcon_omp = 0.375
+  call getin('fact_cldcon',fact_cldcon_omp)
+
+!
+!Config Key  = facttemps
+!Config Desc =  
+!Config Def  = 1.e-4
+!Config Help = 
+!
+  facttemps_omp = 1.e-4
+  call getin('facttemps',facttemps_omp)
+
+!
+!Config Key  = ok_newmicro
+!Config Desc =  
+!Config Def  = .true.
+!Config Help = 
+!
+  ok_newmicro_omp = .true.
+  call getin('ok_newmicro',ok_newmicro_omp)
+!
+!Config Key  = ratqsbas
+!Config Desc =  
+!Config Def  = 0.01
+!Config Help = 
+!
+  ratqsbas_omp = 0.01
+  call getin('ratqsbas',ratqsbas_omp)
+!
+!Config Key  = ratqshaut
+!Config Desc =  
+!Config Def  = 0.3
+!Config Help = 
+!
+  ratqshaut_omp = 0.3
+  call getin('ratqshaut',ratqshaut_omp)
+
+!
+!Config Key  = rad_froid
+!Config Desc =  
+!Config Def  = 35.0
+!Config Help = 
+!
+  rad_froid_omp = 35.0
+  call getin('rad_froid',rad_froid_omp)
+
+!
+!Config Key  = rad_chau1
+!Config Desc =  
+!Config Def  = 13.0
+!Config Help = 
+!
+  rad_chau1_omp = 13.0
+  call getin('rad_chau1',rad_chau1_omp)
+
+!
+!Config Key  = rad_chau2
+!Config Desc =  
+!Config Def  = 9.0
+!Config Help = 
+!
+  rad_chau2_omp = 9.0
+  call getin('rad_chau2',rad_chau2_omp)
+
+!
+!Config Key  = top_height
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  top_height_omp = 3
+  call getin('top_height',top_height_omp)
+
+!
+!Config Key  = overlap
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  overlap_omp = 3
+  call getin('overlap',overlap_omp)
+
+
+!
+!
+!Config Key  = cdmmax
+!Config Desc =
+!Config Def  = 1.3E-3
+!Config Help =
+!
+  cdmmax_omp = 1.3E-3
+  call getin('cdmmax',cdmmax_omp)
+
+!
+!Config Key  = cdhmax
+!Config Desc =
+!Config Def  = 1.1E-3
+!Config Help =
+!
+  cdhmax_omp = 1.1E-3
+  call getin('cdhmax',cdhmax_omp)
+
+!261103
+!
+!Config Key  = ksta
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_omp = 1.0e-10
+  call getin('ksta',ksta_omp)
+
+!
+!Config Key  = ksta_ter
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_ter_omp = 1.0e-10
+  call getin('ksta_ter',ksta_ter_omp)
+
+!
+!Config Key  = ok_kzmin
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+  ok_kzmin_omp = .true.
+  call getin('ok_kzmin',ok_kzmin_omp)
+
+!
+!Config Key  = fmagic
+!Config Desc = 
+!Config Def  = 1.
+!Config Help = Used in albedo.F
+!
+  fmagic_omp = 1.
+  call getin('fmagic',fmagic_omp)
+
+!Config Key = ok_lic_melt
+!Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau
+!Config Def  = .false.
+!Config Help = mettre a .false. pour assurer la conservation en eau
+  ok_lic_melt_omp = .false.
+  call getin('ok_lic_melt', ok_lic_melt_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Config Key  = iflag_pbl
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_pbl_omp = 1
+  call getin('iflag_pbl',iflag_pbl_omp)
+!
+!Config Key  = iflag_thermals
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_thermals_omp = 0
+  call getin('iflag_thermals',iflag_thermals_omp)
+!
+!
+!Config Key  = nsplit_thermals
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  nsplit_thermals_omp = 1
+  call getin('nsplit_thermals',nsplit_thermals_omp)
+
+
+
+!
+!Config Key  = lev_histhf
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histhf_omp = 1
+  call getin('lev_histhf',lev_histhf_omp)
+
+!
+!Config Key  = lev_histday
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histday_omp = 1
+  call getin('lev_histday',lev_histday_omp)
+
+!
+!Config Key  = lev_histmth
+!Config Desc =
+!Config Def  = 2
+!Config Help =
+!
+  lev_histmth_omp = 2
+  call getin('lev_histmth',lev_histmth_omp)
+
+  !
+!Config Key  = type_run
+!Config Desc =
+!Config Def  = 'AMIP'/'CFMIP'  ou 'CLIM'/'ENSP'
+!Config Help =
+!
+  type_run_omp = 'AMIP'
+  call getin('type_run',type_run_omp)
+
+!
+!Config Key  = ok_isccp
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+! ok_isccp = .true.
+  ok_isccp_omp = .false.
+  call getin('ok_isccp',ok_isccp_omp)
+
+!
+! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone 
+! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc"
+!
+!Config Key  = lonmin_ins
+!Config Desc = 100.  
+!Config Def  = longitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   lonmin_ins_omp = 100.
+   call getin('lonmin_ins',lonmin_ins_omp)
+!
+!Config Key  = lonmax_ins
+!Config Desc = 130. 
+!Config Def  = longitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   lonmax_ins = 130.
+   call getin('lonmax_ins',lonmax_ins_omp)
+!
+!Config Key  = latmin_ins
+!Config Desc = -20.  
+!Config Def  = latitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   latmin_ins_omp = -20.
+   call getin('latmin_ins',latmin_ins_omp)
+!
+!Config Key  = latmax_ins
+!Config Desc = 20. 
+!Config Def  = latitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   latmax_ins_omp = 20.
+   call getin('latmax_ins',latmax_ins_omp)
+!
+!Config Key  = ecrit_hf
+!Config Desc =
+!Config Def  = 1./8. !toutes les 3h
+!Config Help =
+!
+  ecrit_hf_omp = 1./8.
+  call getin('ecrit_hf',ecrit_hf_omp)
+!
+!Config Key  = ecrit_day
+!Config Desc =
+!Config Def  = 1.0 !tous les jours
+!Config Help = nombre de jours pour ecriture fichier histday.nc
+!
+  ecrit_day_omp = 1.0
+  call getin('ecrit_day',ecrit_day_omp)
+!
+!Config Key  = ecrit_mth
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_mth_omp = 30.
+  call getin('ecrit_mth',ecrit_mth_omp)
+!
+!Config Key  = ecrit_tra
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_tra_omp = 30.
+  call getin('ecrit_tra',ecrit_tra_omp)
+!
+!Config Key  = ecrit_reg
+!Config Desc =
+!Config Def  = 0.25  !4 fois par jour
+!Config Help =
+!
+  ecrit_reg_omp = 0.25   !4 fois par jour
+  call getin('ecrit_reg',ecrit_reg_omp)
+!
+!
+!
+!Config Key  = ok_slab_sicOBS
+!Config Desc =
+!Config Def  = .true.
+!Config Help = Pour faire tourner le slab avec fraction 
+!              de glace de mer Observee
+!
+  ok_slab_sicOBS_omp = .true.
+  call getin('ok_slab_sicOBS', ok_slab_sicOBS_omp)
+
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+    R_ecc = R_ecc_omp
+    R_peri = R_peri_omp
+    R_incl = R_incl_omp
+    solaire = solaire_omp
+    co2_ppm = co2_ppm_omp
+    RCO2 = RCO2_omp
+    CH4_ppb = CH4_ppb_omp
+    RCH4 = RCH4_omp
+    N2O_ppb = N2O_ppb_omp
+    RN2O = RN2O_omp
+    CFC11_ppt = CFC11_ppt_omp
+    RCFC11 = RCFC11_omp
+    CFC12_ppt = CFC12_ppt_omp
+    RCFC12 = RCFC12_omp
+    epmax = epmax_omp
+    ok_adj_ema = ok_adj_ema_omp
+    iflag_clw = iflag_clw_omp
+    cld_lc_lsc = cld_lc_lsc_omp
+    cld_lc_con = cld_lc_con_omp
+    cld_tau_lsc = cld_tau_lsc_omp
+    cld_tau_con = cld_tau_con_omp
+    ffallv_lsc = ffallv_lsc_omp
+    ffallv_con = ffallv_con_omp
+    coef_eva = coef_eva_omp
+    reevap_ice = reevap_ice_omp
+    iflag_pdf = iflag_pdf_omp
+    rad_froid = rad_froid_omp
+    rad_chau1 = rad_chau1_omp
+    rad_chau2 = rad_chau2_omp
+    top_height = top_height_omp
+    overlap = overlap_omp
+    cdmmax = cdmmax_omp
+    cdhmax = cdhmax_omp
+    ksta = ksta_omp
+    ksta_ter = ksta_ter_omp
+    ok_kzmin = ok_kzmin_omp
+    fmagic = fmagic_omp
+    iflag_pbl = iflag_pbl_omp
+    lev_histhf = lev_histhf_omp
+    lev_histday = lev_histday_omp
+    lev_histmth = lev_histmth_omp
+
+    ocean = ocean_omp
+    ok_veget = ok_veget_omp
+    ok_newmicro = ok_newmicro_omp
+    ok_journe = ok_journe_omp
+    ok_hf = ok_hf_omp
+    ok_mensuel = ok_mensuel_omp
+    ok_instan = ok_instan_omp
+    freq_ISCCP = freq_ISCCP_omp
+    ecrit_ISCCP = ecrit_ISCCP_omp
+    ok_ade = ok_ade_omp
+    ok_aie = ok_aie_omp
+    bl95_b0 = bl95_b0_omp
+    bl95_b1 = bl95_b1_omp
+    fact_cldcon = fact_cldcon_omp
+    facttemps = facttemps_omp
+    ratqsbas = ratqsbas_omp
+    ratqshaut = ratqshaut_omp
+    iflag_cldcon = iflag_cldcon_omp
+    iflag_ratqs = iflag_ratqs_omp
+    ip_ebil_phy = ip_ebil_phy_omp
+    iflag_thermals = iflag_thermals_omp
+    nsplit_thermals = nsplit_thermals_omp
+    type_run = type_run_omp
+    ok_isccp = ok_isccp_omp
+    seuil_inversion=seuil_inversion_omp
+    lonmin_ins = lonmin_ins_omp
+    lonmax_ins = lonmax_ins_omp
+    latmin_ins = latmin_ins_omp
+    latmax_ins = latmax_ins_omp
+    ecrit_hf   = ecrit_hf_omp
+    ecrit_day = ecrit_day_omp
+    ecrit_mth = ecrit_mth_omp
+    ecrit_tra = ecrit_tra_omp
+    ecrit_reg = ecrit_reg_omp
+    ok_slab_sicOBS = ok_slab_sicOBS_omp
+    cvl_corr = cvl_corr_omp
+    ok_lic_melt = ok_lic_melt_omp
+
+!$OMP MASTER
+
+  write(numout,*)' ##############################################'
+  write(numout,*)' Configuration des parametres de la physique: '
+  write(numout,*)' Config ocean = ', ocean
+  write(numout,*)' Config veget = ', ok_veget
+  write(numout,*)' Sortie journaliere = ', ok_journe
+  write(numout,*)' Sortie haute frequence = ', ok_hf
+  write(numout,*)' Sortie mensuelle = ', ok_mensuel
+  write(numout,*)' Sortie instantanee = ', ok_instan
+  write(numout,*)' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP
+  write(numout,*)' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP
+  write(numout,*)' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy
+  write(numout,*)' Excentricite = ',R_ecc
+  write(numout,*)' Equinoxe = ',R_peri
+  write(numout,*)' Inclinaison =',R_incl
+  write(numout,*)' Constante solaire =',solaire
+  write(numout,*)' co2_ppm =',co2_ppm
+  write(numout,*)' RCO2 = ',RCO2
+  write(numout,*)' CH4_ppb =',CH4_ppb,' RCH4 = ',RCH4
+  write(numout,*)' N2O_ppb =',N2O_ppb,' RN2O =  ',RN2O
+  write(numout,*)' CFC11_ppt=',CFC11_ppt,' RCFC11 =  ',RCFC11
+  write(numout,*)' CFC12_ppt=',CFC12_ppt,' RCFC12 =  ',RCFC12
+  write(numout,*)' cvl_corr=', cvl_corr
+  write(numout,*)'ok_lic_melt=', ok_lic_melt
+  write(numout,*)' epmax = ', epmax
+  write(numout,*)' ok_adj_ema = ', ok_adj_ema
+  write(numout,*)' iflag_clw = ', iflag_clw
+  write(numout,*)' cld_lc_lsc = ', cld_lc_lsc
+  write(numout,*)' cld_lc_con = ', cld_lc_con
+  write(numout,*)' cld_tau_lsc = ', cld_tau_lsc
+  write(numout,*)' cld_tau_con = ', cld_tau_con
+  write(numout,*)' ffallv_lsc = ', ffallv_lsc
+  write(numout,*)' ffallv_con = ', ffallv_con
+  write(numout,*)' coef_eva = ', coef_eva
+  write(numout,*)' reevap_ice = ', reevap_ice
+  write(numout,*)' iflag_pdf = ', iflag_pdf
+  write(numout,*)' iflag_cldcon = ', iflag_cldcon
+  write(numout,*)' iflag_ratqs = ', iflag_ratqs
+  write(numout,*)' seuil_inversion = ', seuil_inversion
+  write(numout,*)' fact_cldcon = ', fact_cldcon
+  write(numout,*)' facttemps = ', facttemps
+  write(numout,*)' ok_newmicro = ',ok_newmicro 
+  write(numout,*)' ratqsbas = ',ratqsbas 
+  write(numout,*)' ratqshaut = ',ratqshaut 
+  write(numout,*)' top_height = ',top_height 
+  write(numout,*)' overlap = ',overlap 
+  write(numout,*)' cdmmax = ',cdmmax 
+  write(numout,*)' cdhmax = ',cdhmax 
+  write(numout,*)' ksta = ',ksta 
+  write(numout,*)' ksta_ter = ',ksta_ter 
+  write(numout,*)' ok_kzmin = ',ok_kzmin 
+  write(numout,*)' fmagic = ',fmagic
+  write(numout,*)' ok_ade = ',ok_ade
+  write(numout,*)' ok_aie = ',ok_aie
+  write(numout,*)' bl95_b0 = ',bl95_b0
+  write(numout,*)' bl95_b1 = ',bl95_b1
+  write(numout,*)' lev_histhf = ',lev_histhf 
+  write(numout,*)' lev_histday = ',lev_histday 
+  write(numout,*)' lev_histmth = ',lev_histmth 
+  write(numout,*)' iflag_pbl = ', iflag_pbl
+  write(numout,*)' iflag_thermals = ', iflag_thermals
+  write(numout,*)' type_run = ',type_run 
+  write(numout,*)' ok_isccp = ',ok_isccp 
+  write(numout,*)' lonmin lonmax latmin latmax bilKP_ins =',&
+ & lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+  write(numout,*)' ecrit_ hf, day, mth, reg, tra, ISCCP',&
+ & ecrit_hf, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP
+
+!$OMP END MASTER
+
+  return
+  
+  end subroutine conf_phys
+
+!
+!#################################################################
+!
+
+   subroutine conf_interface(tau_calv)
+
+   use IOIPSL
+   implicit none
+
+! Configuration de l'interace atm/surf
+!
+! tau_calv:    temps de relaxation pour la fonte des glaciers
+
+  REAL          :: tau_calv
+  REAL,SAVE     :: tau_calv_omp
+
+! Local
+  integer              :: numout = 6
+!
+!Config Key  = tau_calv
+!Config Desc = temps de relaxation pour fonte des glaciers en jours
+!Config Def  = 1 an 
+!Config Help = 
+!
+  tau_calv_omp = 360.*10.
+!$OMP MASTER
+  call getin('tau_calv',tau_calv_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  tau_calv=tau_calv_omp
+  
+!$OMP MASTER
+  write(numout,*)' ##############################################'
+  WRITE(numout,*)' Configuration de l''interface atm/surfaces  : '
+  WRITE(numout,*)' tau_calv = ',tau_calv
+!$OMP END MASTER
+
+  return
+
+  end subroutine conf_interface
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conflx.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conflx.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conflx.F	(revision 984)
@@ -0,0 +1,1676 @@
+!
+! $Header$
+!
+      SUBROUTINE conflx (dtime,pres_h,pres_f,
+     e                   t, q, con_t, con_q, pqhfl, w,
+     s                   d_t, d_q, rain, snow,
+     s                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s                   kcbot, kctop, kdtop, pmflxr, pmflxs)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+c Objet: Schema flux de masse pour la convection 
+c        (schema de Tiedtke avec qqs modifications mineures)
+c Dec.97: Prise en compte des modifications introduites par
+c         Olivier Boucher et Alexandre Armengaud pour melange
+c         et lessivage des traceurs passifs.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c Entree:
+      REAL dtime            ! pas d'integration (s)
+      REAL pres_h(klon,klev+1) ! pression half-level (Pa)
+      REAL pres_f(klon,klev)! pression full-level (Pa)
+      REAL t(klon,klev)     ! temperature (K)
+      REAL q(klon,klev)     ! humidite specifique (g/g)
+      REAL w(klon,klev)     ! vitesse verticale (Pa/s)
+      REAL con_t(klon,klev) ! convergence de temperature (K/s)
+      REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s)
+      REAL pqhfl(klon)      ! evaporation (negative vers haut) mm/s
+c Sortie:
+      REAL d_t(klon,klev)   ! incrementation de temperature
+      REAL d_q(klon,klev)   ! incrementation d'humidite
+      REAL pmfu(klon,klev)  ! flux masse (kg/m2/s) panache ascendant
+      REAL pmfd(klon,klev)  ! flux masse (kg/m2/s) panache descendant
+      REAL pen_u(klon,klev)
+      REAL pen_d(klon,klev)
+      REAL pde_u(klon,klev)
+      REAL pde_d(klon,klev)
+      REAL rain(klon)       ! pluie (mm/s)
+      REAL snow(klon)       ! neige (mm/s)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER kcbot(klon)  ! niveau du bas de la convection
+      INTEGER kctop(klon)  ! niveau du haut de la convection
+      INTEGER kdtop(klon)  ! niveau du haut des downdrafts
+c Local:
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pqs(klon,klev)
+      REAL pvervel(klon,klev)
+      LOGICAL land(klon)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL paprsf(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL zcvgq(klon,klev)
+      REAL zcvgt(klon,klev)
+cAA
+      REAL zmfu(klon,klev) 
+      REAL zmfd(klon,klev)
+      REAL zen_u(klon,klev)
+      REAL zen_d(klon,klev)
+      REAL zde_u(klon,klev)
+      REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
+cAA
+
+c
+      INTEGER i, k
+      REAL zdelta, zqsat
+c
+#include "FCTTRE.h"
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kcbot(i) = 0
+         kctop(i) = 0
+         kdtop(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         pmfu(i,k) = 0.0
+         pmfd(i,k) = 0.0
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+         zmfu(i,k) = 0.0
+         zmfd(i,k) = 0.0
+         zen_u(i,k) = 0.0
+         zde_u(i,k) = 0.0
+         zen_d(i,k) = 0.0
+         zde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c calculer la nature du sol (pour l'instant, ocean partout)
+      DO i = 1, klon
+         land(i) = .FALSE.
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         paprsf(i,k) = pres_f(i,klev-k+1)
+         paprs(i,k) = pres_h(i,klev+1-k+1)
+         pvervel(i,k) = w(i,klev+1-k)
+         zcvgt(i,k) = con_t(i,klev-k+1)
+         zcvgq(i,k) = con_q(i,klev-k+1)
+c
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k)))
+         zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k)
+         zqsat=MIN(0.5,zqsat)
+         zqsat=zqsat/(1.-RETV  *zqsat)
+         pqs(i,k) = zqsat
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pres_h(i,1)
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                   / (0.5*(paprs(i,klev+1)+paprsf(i,klev)))
+     .                   * (paprs(i,klev+1)-paprsf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1)
+     .              + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1)
+     .                   * (paprsf(i,k+1)-paprsf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL flxmain(dtime, pt, pq, pqs, pqhfl,
+     .             paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel,
+     .             rain, snow, kcbot, kctop, kdtop,
+     .             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     .             d_t_bis, d_q_bis, zmflxr, zmflxs)
+C
+cAA--------------------------------------------------------
+cAA rem : De la meme facon que l'on effectue le reindicage 
+cAA       pour la temperature t et le champ q 
+cAA       on reindice les flux necessaires a la convection 
+cAA       des traceurs
+cAA--------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = dtime*d_q_bis(i,k)
+         d_t(i,klev+1-k) = dtime*d_t_bis(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         pmfu(i,1)= 0.
+         pmfd(i,1)= 0.
+         pen_d(i,1)= 0.
+         pde_d(i,1)= 0.
+      ENDDO
+     
+      DO k = 2, klev
+      DO i = 1, klon
+         pmfu(i,klev+2-k)= zmfu(i,k)
+         pmfd(i,klev+2-k)= zmfd(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pen_u(i,klev+1-k)=  zen_u(i,k)
+         pde_u(i,klev+1-k)=  zde_u(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+         pen_d(i,klev+1-k)= -zen_d(i,k+1)
+         pde_d(i,klev+1-k)= -zde_d(i,k+1)
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,klev+2-k)= zmflxr(i,k)
+         pmflxs(i,klev+2-k)= zmflxs(i,k)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c--------------------------------------------------------------------
+      SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph,
+     .                   pgeo, ldland, ptte, pqte, pvervel,
+     .                   prsfc, pssfc, kcbot, kctop, kdtop,
+c     *                   ldcum, ktype,
+     .                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .                   dt_con, dq_con, pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C     ------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     ----------------------------------------------------------------
+      REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev)
+      REAL ptte(klon,klev)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev)
+      REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1)
+      REAL pqhfl(klon)
+c
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev)
+      REAL prsfc(klon), pssfc(klon)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+c
+      REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev)
+      REAL zgeoh(klon,klev)
+      REAL zmfub(klon), zmfub1(klon)
+      REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev)
+      REAL zdmfup(klon,klev), zdpmel(klon,klev)
+      REAL zentr(klon), zhcbase(klon)
+      REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+      REAL zrfl(klon)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER  ilab(klon,klev), ictop0(klon)
+      LOGICAL  llo1
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+      REAL zmfmax, zdh
+      REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+      REAL zhhat, zpbmpt, zgam, zeps, zfac
+      INTEGER i, k, ikb, itopm2, kcum
+c
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL pen_d(klon,klev), pde_d(klon,klev)
+c
+      REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev)
+      REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev)
+      INTEGER kdtop(klon)
+      LOGICAL lddraf(klon)
+C---------------------------------------------------------------------
+      LOGICAL firstcal
+      SAVE firstcal
+      DATA firstcal / .TRUE. /
+c$OMP THREADPRIVATE(firstcal)
+C---------------------------------------------------------------------
+      IF (firstcal) THEN
+         CALL flxsetup
+         firstcal = .FALSE.
+      ENDIF
+C---------------------------------------------------------------------
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         dt_con(i,k) = 0.0
+         dq_con(i,k) = 0.0
+      ENDDO
+      ENDDO
+c----------------------------------------------------------------------
+c initialiser les variables et faire l'interpolation verticale
+c----------------------------------------------------------------------
+      CALL flxini(pten, pqen, pqsen, pgeo,
+     .     paph, zgeoh, ztenh, zqenh, zqsenh,
+     .     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp,
+     .     pmfu, zmfus, zmfuq, zdmfup,
+     .     zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+c---------------------------------------------------------------------
+c determiner les valeurs au niveau de base de la tour convective
+c---------------------------------------------------------------------
+      CALL flxbase(ztenh, zqenh, zgeoh, paph,
+     *            ptu, pqu, plu, ldcum, kcbot, ilab)
+c---------------------------------------------------------------------
+c calculer la convergence totale de l'humidite et celle en provenance
+c de la couche limite, plus precisement, la convergence integree entre
+c le sol et la base de la convection. Cette derniere convergence est
+c comparee avec l'evaporation obtenue dans la couche limite pour
+c determiner le type de la convection
+c---------------------------------------------------------------------
+      k=1
+      DO i = 1, klon
+         zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k))
+         zdhpbl(i) = 0.0
+         zdqpbl(i) = 0.0
+      ENDDO
+c
+      DO k=2,klev
+      DO i = 1, klon
+          zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+          IF (k.GE.kcbot(i)) THEN
+             zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+             zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k))
+     .                          *(paph(i,k+1)-paph(i,k))
+          ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         ktype(i) = 2
+         if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1
+ccc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+      ENDDO
+c
+c---------------------------------------------------------------------
+c determiner le flux de masse entrant a travers la base.
+c on ignore, pour l'instant, l'effet du panache descendant
+c---------------------------------------------------------------------
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb)
+         zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN
+            zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub(i) = 0.01
+            ldcum(i)=.FALSE.
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh
+         ENDIF
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         zmfub(i) = MIN(zmfub(i),zmfmax)
+         zentr(i) = ENTRSCV
+         IF (ktype(i).EQ.1) zentr(i) = ENTRPEN
+      ENDDO
+C-----------------------------------------------------------------------
+C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+C-----------------------------------------------------------------------
+c (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+c     considerer l'entrainement ni le detrainement du panache, sachant
+c     ces derniers peuvent abaisser la hauteur theorique.
+c
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb)
+         ictop0(i)=kcbot(i)-1
+      ENDDO
+c
+      zalvdcp=RLVTT/RCPD
+      DO k=klev-1,3,-1
+      DO i = 1, klon
+         zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k)
+         zgam=R5LES*zalvdcp*zqsenh(i,k)/
+     .        ((1.-RETV  *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2)
+         zzz=RCPD*ztenh(i,k)*0.608
+         zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)*
+     .               MAX(zqsenh(i,k)-zqenh(i,k),0.)
+         IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k
+      ENDDO
+      ENDDO
+c
+c (B) calculer le panache ascendant
+c
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+      IF (kcum.EQ.0) GO TO 1000
+C
+C verifier l'epaisseur de la convection et changer eventuellement
+c le taux d'entrainement/detrainement
+C
+      DO i = 1, klon
+         zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i))
+         IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2
+         IF(ldcum(i)) ictop0(i)=kctop(i)
+         IF(ktype(i).EQ.2) zentr(i)=ENTRSCV
+      ENDDO
+c
+      IF (lmfdd) THEN  ! si l'on considere le panache descendant
+c
+c calculer la precipitation issue du panache ascendant pour 
+c determiner l'existence du panache descendant dans la convection
+      DO i = 1, klon
+         zrfl(i)=zdmfup(i,1)
+      ENDDO
+      DO k=2,klev
+      DO i = 1, klon
+         zrfl(i)=zrfl(i)+zdmfup(i,k)
+      ENDDO
+      ENDDO
+c
+c determiner le LFS (level of free sinking: niveau de plonge libre)
+      CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu,
+     *     ldcum,    kcbot,    kctop,    zmfub,    zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     kdtop,    lddraf)
+c
+c calculer le panache descendant
+      CALL flxddraf(ztenh,    zqenh,
+     *     zgeoh,    paph,     zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     lddraf, pen_d, pde_d)
+c
+c calculer de nouveau le flux de masse entrant a travers la base
+c de la convection, sachant qu'il a ete modifie par le panache
+c descendant
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         ikb = kcbot(i)
+         llo1 = PMFD(i,ikb).LT.0.
+         zeps = 0.
+         IF ( llo1 ) zeps = CMFDEPS
+         zqumqe = pqu(i,ikb)+plu(i,ikb)-
+     .            zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb)
+         zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10)
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)
+     .       .AND.zmfub(i).LT.zmfmax) THEN
+            zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub1(i) = zmfub(i)
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)-
+     .            (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh
+         ENDIF
+         IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND.
+     .              ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) )
+     .      zmfub1(i) = zmfub(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         zfac = zmfub1(i)/MAX(zmfub(i),1.E-10)
+         pmfd(i,k) = pmfd(i,k)*zfac
+         zmfds(i,k) = zmfds(i,k)*zfac
+         zmfdq(i,k) = zmfdq(i,k)*zfac
+         zdmfdp(i,k) = zdmfdp(i,k)*zfac
+         pen_d(i,k) = pen_d(i,k)*zfac
+         pde_d(i,k) = pde_d(i,k)*zfac
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (lddraf(i)) zmfub(i)=zmfub1(i)
+      ENDDO
+c
+      ENDIF   ! fin de test sur lmfdd
+c
+c-----------------------------------------------------------------------
+c calculer de nouveau le panache ascendant
+c-----------------------------------------------------------------------
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+c
+c-----------------------------------------------------------------------
+c determiner les flux convectifs en forme finale, ainsi que
+c la quantite des precipitations
+c-----------------------------------------------------------------------
+      CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, 
+     .     ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum,
+     .     pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude,
+     .     zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2,
+     .     pmflxr, pmflxs)
+c
+c----------------------------------------------------------------------
+c calculer les tendances pour T et Q
+c----------------------------------------------------------------------
+      CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten,
+     e     zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel,
+     s     dt_con,dq_con)
+c
+ 1000 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh,
+     .           pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq,
+     .           pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude,
+     .           klab,pen_u, pde_u, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+C AND INITIALIZES VALUES FOR UPDRAFTS
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pten(klon,klev)   ! temperature (environnement)
+      REAL pqen(klon,klev)   ! humidite (environnement)
+      REAL pqsen(klon,klev)  ! humidite saturante (environnement)
+      REAL pgeo(klon,klev)   ! geopotentiel (g * metre)
+      REAL pgeoh(klon,klev)  ! geopotentiel aux demi-niveaux
+      REAL paph(klon,klev+1) ! pression aux demi-niveaux
+      REAL ptenh(klon,klev)  ! temperature aux demi-niveaux
+      REAL pqenh(klon,klev)  ! humidite aux demi-niveaux
+      REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux
+C
+      REAL ptu(klon,klev)    ! temperature du panache ascendant (p-a)
+      REAL pqu(klon,klev)    ! humidite du p-a
+      REAL plu(klon,klev)    ! eau liquide du p-a
+      REAL pmfu(klon,klev)   ! flux de masse du p-a
+      REAL pmfus(klon,klev)  ! flux de l'energie seche dans le p-a
+      REAL pmfuq(klon,klev)  ! flux de l'humidite dans le p-a
+      REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a
+      REAL plude(klon,klev)  ! quantite de l'eau liquide jetee du
+c                              p-a a l'environnement
+      REAL pdpmel(klon,klev) ! quantite de neige fondue
+c
+      REAL ptd(klon,klev)    ! temperature du panache descendant (p-d)
+      REAL pqd(klon,klev)    ! humidite du p-d
+      REAL pmfd(klon,klev)   ! flux de masse du p-d
+      REAL pmfds(klon,klev)  ! flux de l'energie seche dans le p-d
+      REAL pmfdq(klon,klev)  ! flux de l'humidite dans le p-d
+      REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d
+c
+      REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a
+      REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a
+      REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d
+      REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d
+C
+      INTEGER  klab(klon,klev)
+      LOGICAL  llflag(klon)
+      INTEGER k, i, icall
+      REAL zzs
+C----------------------------------------------------------------------
+C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+C----------------------------------------------------------------------
+      DO 130 k = 2, klev
+c
+      DO i = 1, klon
+         pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5
+         ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1),
+     .             RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD
+         pqsenh(i,k)=pqsen(i,k-1)
+         llflag(i)=.TRUE.
+      ENDDO
+c
+      icall=0
+      CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall)
+c
+      DO i = 1, klon
+         pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1))
+     .               +(pqsenh(i,k)-pqsen(i,k-1))
+         pqenh(i,k)=MAX(pqenh(i,k),0.)
+      ENDDO
+c
+  130 CONTINUE
+C
+      DO 140 i = 1, klon
+         ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)-
+     1                   pgeoh(i,klev))/RCPD
+         pqenh(i,klev)=pqen(i,klev)
+         ptenh(i,1)=pten(i,1)
+         pqenh(i,1)=pqen(i,1)
+         pgeoh(i,1)=pgeo(i,1)
+  140 CONTINUE
+c
+      DO 160 k = klev-1, 2, -1
+      DO 150 i = 1, klon
+         zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k),
+     .             RCPD*ptenh(i,k+1)+pgeoh(i,k+1))
+         ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD
+  150 CONTINUE
+  160 CONTINUE
+C
+C-----------------------------------------------------------------------
+C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+C-----------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         ptu(i,k) = ptenh(i,k)
+         pqu(i,k) = pqenh(i,k)
+         plu(i,k) = 0.
+         pmfu(i,k) = 0.
+         pmfus(i,k) = 0.
+         pmfuq(i,k) = 0.
+         pdmfup(i,k) = 0.
+         pdpmel(i,k) = 0.
+         plude(i,k) = 0.
+c
+         klab(i,k) = 0
+c
+         ptd(i,k) = ptenh(i,k)
+         pqd(i,k) = pqenh(i,k)
+         pmfd(i,k) = 0.0
+         pmfds(i,k) = 0.0
+         pmfdq(i,k) = 0.0
+         pdmfdp(i,k) = 0.0
+c
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph,
+     *     ptu, pqu, plu, ldcum, kcbot, klab)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+C
+C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+C   klab=1 FOR SUBCLOUD LEVELS
+C   klab=2 FOR CONDENSATION LEVEL
+C
+C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C       ----------------------------------------------------------------
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      INTEGER  klab(klon,klev), kcbot(klon)
+C
+      LOGICAL llflag(klon), ldcum(klon)
+      INTEGER i, k, icall, is
+      REAL zbuo, zqold(klon)
+C----------------------------------------------------------------------
+C INITIALIZE VALUES AT LIFTING LEVEL
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,klev)=1
+         kcbot(i)=klev-1
+         ldcum(i)=.FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C DO ASCENT IN SUBCLOUD LAYER,
+C CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+C ADJUST T,Q AND L ACCORDINGLY
+C CHECK FOR BUOYANCY AND SET FLAGS
+C----------------------------------------------------------------------
+      DO 290 k = klev-1, 2, -1
+c
+      is = 0
+      DO i = 1, klon
+         IF (klab(i,k+1).EQ.1) is = is + 1
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+      DO i = 1, klon
+      IF(llflag(i)) THEN
+         pqu(i,k) = pqu(i,k+1)
+         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k) = 1
+         zqold(i) = pqu(i,k)
+      ENDIF
+      ENDDO
+c
+      icall=1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+c
+      DO i = 1, klon
+      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) kcbot(i) = k
+         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+  290 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen,
+     .     pgeo, pgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, klab, ptu, pqu, plu,
+     .     pmfu, pmfub, pentr, pmfus, pmfuq,
+     .     pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum,
+     .     pen_u, pde_u)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+C FOR CUMULUS PARAMETERIZATION
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL pdtime
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pgeo(klon,klev), pgeoh(klon,klev)
+      REAL pap(klon,klev), paph(klon,klev+1)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev) ! vitesse verticale en Pa/s
+C
+      REAL pmfub(klon), pentr(klon)
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pdmfup(klon,klev)
+      INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon)
+      INTEGER kctop0(klon)
+      LOGICAL ldland(klon), ldcum(klon)
+C
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL zqold(klon)
+      REAL zdland(klon)
+      LOGICAL llflag(klon)
+      INTEGER k, i, is, icall, kcum
+      REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+      REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+c
+      REAL zpbot(klon), zptop(klon), zrho(klon)
+      REAL zdprho, zentr, zpmid, zmftest, zmfmax
+      LOGICAL llo1, llo2
+c
+      REAL zwmax(klon), zzzmb
+      INTEGER klwmin(klon) ! level of maximum vertical velocity
+C----------------------------------------------------------------------
+      ztglace = RTT - 13.
+c
+c Chercher le niveau ou la vitesse verticale est maximale:
+      DO i = 1, klon
+         klwmin(i) = klev
+         zwmax(i) = 0.0
+      ENDDO
+      DO k = klev, 3, -1
+      DO i = 1, klon
+      IF (pvervel(i,k).LT.zwmax(i)) THEN
+         zwmax(i) = pvervel(i,k)
+         klwmin(i) = k
+      ENDIF
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+C SET DEFAULT VALUES
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (.NOT.ldcum(i)) ktype(i)=0
+      ENDDO
+c
+      DO k=1,klev
+      DO i = 1, klon
+         plu(i,k)=0.
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         plude(i,k)=0.
+         pdmfup(i,k)=0.
+         IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0
+         IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (ldland(i)) THEN
+         zdland(i)=3.0E4
+         zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i))
+         IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi
+         zdland(i)=MAX(3.0E4,zdland(i))
+         zdland(i)=MIN(5.0E4,zdland(i))
+      ENDIF
+      ENDDO
+C
+C Initialiser les valeurs au niveau d'ascendance
+C
+      DO i = 1, klon
+         kctop(i) = klev-1
+         IF (.NOT.ldcum(i)) THEN
+            kcbot(i) = klev-1
+            pmfub(i) = 0.
+            pqu(i,klev) = 0.
+         ENDIF
+         pmfu(i,klev) = pmfub(i)
+         pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev))
+         pmfuq(i,klev) = pmfub(i)*pqu(i,klev)
+      ENDDO
+c
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C  DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+C  BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+C  BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+C  THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+C----------------------------------------------------------------------
+      DO 480 k = klev-1,3,-1
+c
+      IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN
+         DO i = 1, klon
+         IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND.
+     .       pqen(i,k).GT.0.9*pqsen(i,k)) THEN
+            ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD
+            pqu(i,k+1) = pqen(i,k)
+            plu(i,k+1) = 0.0
+            zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG)
+            zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime)
+            pmfub(i) = MIN(zzzmb,zmfmax)
+            pmfu(i,k+1) = pmfub(i)
+            pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1))
+            pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1)
+            pmful(i,k+1) = 0.0
+            pdmfup(i,k+1) = 0.0
+            kcbot(i) = k
+            klab(i,k+1) = 1
+            ktype(i) = 3
+            pentr(i) = ENTRMID
+         ENDIF
+         ENDDO
+      ENDIF
+c
+      is = 0
+      DO i = 1, klon
+         is = is + klab(i,k+1)
+         IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE.
+      ENDDO
+      IF (is .EQ. 0) GOTO 480
+c
+c calculer le taux d'entrainement et de detrainement
+c
+      DO i = 1, klon
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1))
+         zpbot(i)=paph(i,kcbot(i))
+         zptop(i)=paph(i,kctop0(i))
+      ENDDO
+c
+      DO 125 i = 1, klon
+      IF(ldcum(i)) THEN
+         zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i))
+         zentr=pentr(i)*pmfu(i,k+1)*zdprho
+         llo1=k.LT.kcbot(i)
+         IF(llo1) pde_u(i,k)=zentr
+         zpmid=0.5*(zpbot(i)+zptop(i))
+         llo2=llo1.AND.ktype(i).EQ.2.AND.
+     .        (zpbot(i)-paph(i,k).LT.0.2E5.OR.
+     .         paph(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND.
+     .        (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2)
+         IF(llo1) THEN
+            zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4)))
+            pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+            pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+         ENDIF
+         IF(llo2.AND.pqenh(i,k+1).GT.1.E-5)
+     .   pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)*
+     .              zrho(i)*zdprho
+      ENDIF
+  125 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+C----------------------------------------------------------------------
+c
+      DO 420 i = 1, klon
+      IF (llflag(i)) THEN
+         IF (k.LT.kcbot(i)) THEN
+            zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+            zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime))
+            pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0)
+         ENDIF
+         pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1))
+c calculer le flux de masse du niveau k a partir de celui du k+1
+         pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+c calculer les valeurs Su, Qu et l du niveau k dans le panache montant
+         zqeen=pqenh(i,k+1)*pen_u(i,k)
+         zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k)
+         zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k)
+         zqude=pqu(i,k+1)*pde_u(i,k)
+         plude(i,k)=plu(i,k+1)*pde_u(i,k)
+         zmfusk=pmfus(i,k+1)+zseen-zscde
+         zmfuqk=pmfuq(i,k+1)+zqeen-zqude
+         zmfulk=pmful(i,k+1)    -plude(i,k)
+         plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))-
+     1               pgeoh(i,k))/RCPD
+         ptu(i,k)=MAX(100.,ptu(i,k))
+         ptu(i,k)=MIN(400.,ptu(i,k))
+         zqold(i)=pqu(i,k)
+      ELSE
+         zqold(i)=0.0
+      ENDIF
+  420 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+C----------------------------------------------------------------------
+c
+      icall = 1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+C
+      DO 440 i = 1, klon
+      IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))
+         IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5
+         IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN
+            kctop(i) = k
+            ldcum(i) = .TRUE.
+            zdnoprc = 1.5E4
+            IF (ldland(i)) zdnoprc = zdland(i)
+            zprcon = CPRCON
+            IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0
+            zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+            pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+            plu(i,k)=zlnew
+         ELSE
+            klab(i,k)=0
+            pmfu(i,k)=0.
+         ENDIF
+      ENDIF
+  440 CONTINUE
+      DO 455 i = 1, klon
+      IF (llflag(i)) THEN
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+      ENDIF
+  455 CONTINUE
+C
+  480 CONTINUE
+C----------------------------------------------------------------------
+C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+C    (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+C           AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+C           FROM PREVIOUS CALCULATIONS ABOVE)
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE.
+         kcbot(i) = MAX(kcbot(i),kctop(i))
+      ENDDO
+c
+      ldcum(1)=ldcum(1)
+c
+      is = 0
+      DO i = 1, klon
+         if (ldcum(i)) is = is + 1
+      ENDDO
+      kcum = is
+      IF (is.EQ.0) GOTO 800
+c
+      DO 530 i = 1, klon
+      IF (ldcum(i)) THEN
+         k=kctop(i)-1
+         pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1)
+         plude(i,k)=pde_u(i,k)*plu(i,k+1)
+         pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k)
+         zlnew=plu(i,k)
+         pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+         plu(i,k)=zlnew
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         plude(i,k-1)=pmful(i,k)
+      ENDIF
+  530 CONTINUE
+C
+  800 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap
+     .  ,  paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop
+     .  ,  ktype, ldcum, pmfu, pmfd, pmfus, pmfds
+     .  ,  pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp
+     .  ,  pten, prfl, psfl, pdpmel, ktopm2
+     .  ,  pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL cevapcu(klon,klev)
+C     -----------------------------------------------------------------
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL paph(klon,klev+1), pgeoh(klon,klev)
+c
+      REAL pap(klon,klev)
+      REAL ztmsmlt, zdelta, zqsat
+C
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfdq(klon,klev)
+      REAL plude(klon,klev)
+      REAL pdmfup(klon,klev), pdpmel(klon,klev)
+cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+cjq 14/11/00 to fix the problem with the negative precipitation.      
+      REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) 
+      REAL prfl(klon), psfl(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+      INTEGER k, kp, i
+      REAL zcons1, zcons2, zcucov, ztmelp2
+      REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+      REAL zrmin, zrfln, zdrfl
+      REAL zpds, zpdr, zdenom
+      INTEGER ktopm2, itop, ikb
+c
+      LOGICAL lddraf(klon)
+      INTEGER kdtop(klon)
+c
+#include "FCTTRE.h"
+c
+      DO 101 k=1,klev
+        DO i=1,klon
+      CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293)
+     1 *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG
+        ENDDO
+ 101  CONTINUE
+c
+c SPECIFY CONSTANTS
+c
+      zcons1 = RCPD/(RLMLT*RG*pdtime)
+      zcons2 = 1./(RG*pdtime)
+      zcucov = 0.05
+      ztmelp2 = RTT + 2.
+c
+c DETERMINE FINAL CONVECTIVE FLUXES
+c
+      itop=klev
+      DO 110 i = 1, klon
+         itop=MIN(itop,kctop(i))
+         IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE.
+         IF(.NOT.ldcum(i)) ktype(i)=0
+  110 CONTINUE
+c
+      ktopm2=itop-2
+      DO 120 k=ktopm2,klev
+      DO 115 i = 1, klon
+      IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN
+         pmfus(i,k)=pmfus(i,k)-pmfu(i,k)*
+     .                (RCPD*ptenh(i,k)+pgeoh(i,k))
+         pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k)
+         zdp = 1.5E4
+         IF ( ldland(i) ) zdp = 3.E4
+c
+c        l'eau liquide detrainee est precipitee quand certaines
+c        conditions sont reunies (sinon, elle est consideree
+c        evaporee dans l'environnement)
+c
+         IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND.
+     .      pqen(i,k-1).GT.0.8*pqsen(i,k-1))
+     .      pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1)
+c
+         IF(lddraf(i).AND.k.GE.kdtop(i)) THEN
+            pmfds(i,k)=pmfds(i,k)-pmfd(i,k)*
+     .                   (RCPD*ptenh(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k)
+         ELSE
+            pmfd(i,k)=0.
+            pmfds(i,k)=0.
+            pmfdq(i,k)=0.
+            pdmfdp(i,k-1)=0.
+         END IF
+      ELSE
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         pdmfup(i,k-1)=0.
+         plude(i,k-1)=0.
+         pmfd(i,k)=0.
+         pmfds(i,k)=0.
+         pmfdq(i,k)=0.
+         pdmfdp(i,k-1)=0.
+      ENDIF
+  115 CONTINUE
+  120 CONTINUE
+c
+      DO 130 k=ktopm2,klev
+      DO 125 i = 1, klon
+      IF(ldcum(i).AND.k.GT.kcbot(i)) THEN
+         ikb=kcbot(i)
+         zzp=((paph(i,klev+1)-paph(i,k))/
+     .        (paph(i,klev+1)-paph(i,ikb)))
+         IF (ktype(i).EQ.3) zzp = zzp**2
+         pmfu(i,k)=pmfu(i,ikb)*zzp
+         pmfus(i,k)=pmfus(i,ikb)*zzp
+         pmfuq(i,k)=pmfuq(i,ikb)*zzp
+         pmful(i,k)=pmful(i,ikb)*zzp
+      ENDIF
+  125 CONTINUE
+  130 CONTINUE
+c
+c CALCULATE RAIN/SNOW FALL RATES
+c CALCULATE MELTING OF SNOW
+c CALCULATE EVAPORATION OF PRECIP
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,k) = 0.0
+         pmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i)) THEN
+         IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN
+            zfac=zcons1*(paph(i,k+1)-paph(i,k))
+            zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2))
+            pdpmel(i,k)=zsnmlt
+            ztmsmlt=pten(i,k)-zsnmlt/zfac
+            zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt))
+            zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k)
+            zqsat=MIN(0.5,zqsat)
+            zqsat=zqsat/(1.-RETV  *zqsat)
+            pqsen(i,k) = zqsat
+         ENDIF
+         IF (pten(i,k).GT.RTT) THEN
+         pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k)
+         ELSE
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)
+           pmflxr(i,k+1)=pmflxr(i,k)
+         ENDIF
+c        si la precipitation est negative, on ajuste le plux du
+c        panache descendant pour eliminer la negativite
+         IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN
+            pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k)
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cjq The new variable is initialized here.
+cjq It contains the humidity which is fed to the downdraft
+cjq by evaporation of precipitation in the column below the base
+cjq of convection.
+cjq 
+cjq In the former version, this term has been subtracted from precip
+cjq as well as the evaporation.
+cjq      
+      DO k = 1, klev
+      DO i = 1, klon 
+         maxpdmfdp(i,k)=0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+       DO kp = k, klev
+        DO i = 1, klon
+         maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp)
+        ENDDO
+       ENDDO
+      ENDDO
+cjq End of initialization
+c      
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN
+         zrfl = pmflxr(i,k) + pmflxs(i,k)
+         IF (zrfl.GT.1.0E-20) THEN
+            zrnew=(MAX(0.,SQRT(zrfl/zcucov)-
+     .            CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))*
+     .            MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov
+            zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k))
+     .            *zcons2*(paph(i,k+1)-paph(i,k))
+            zrnew=MAX(zrnew,zrmin)
+            zrfln=MAX(zrnew,0.)
+            zdrfl=MIN(0.,zrfln-zrfl)
+cjq At least the amount of precipiation needed to feed the downdraft
+cjq with humidity below the base of convection has to be left and can't
+cjq be evaporated (surely the evaporation can't be positive):            
+            zdrfl=MAX(zdrfl,
+     .            MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0))
+cjq End of insertion
+c            
+            zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k))
+            IF (pten(i,k).GT.RTT) THEN
+               zpdr = pdmfdp(i,k)
+               zpds = 0.0
+            ELSE
+               zpdr = 0.0
+               zpds = pdmfdp(i,k)
+            ENDIF
+            pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k)
+     .                    + zdrfl*pmflxr(i,k)*zdenom
+            pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k)
+     .                    + zdrfl*pmflxs(i,k)*zdenom
+            pdmfup(i,k) = pdmfup(i,k) + zdrfl
+         ELSE
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdmfdp(i,k) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) 
+     .    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 210 i = 1, klon
+         prfl(i) = pmflxr(i,klev+1)
+         psfl(i) = pmflxs(i,klev+1)
+  210 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten
+     .  ,  pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp
+     .  ,  pdpmel, dt_con, dq_con)
+      USE dimphy
+      IMPLICIT none
+c----------------------------------------------------------------------
+c calculer les tendances T et Q
+c----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     -----------------------------------------------------------------
+      LOGICAL  llo1
+C
+      REAL pten(klon,klev), paph(klon,klev+1)
+      REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfup(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL pdpmel(klon,klev)
+      LOGICAL ldcum(klon)
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+c
+      INTEGER ktopm2
+      REAL pdtime
+c
+      INTEGER i, k
+      REAL zalv, zdtdt, zdqdt
+c
+      DO 210 k=ktopm2,klev-1
+      DO 220 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .        *(pmfus(i,k+1)-pmfus(i,k)
+     .         +pmfds(i,k+1)-pmfds(i,k)
+     .          -RLMLT*pdpmel(i,k)
+     .          -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+     .         )
+         dt_con(i,k)=zdtdt
+         zdqdt=RG/(paph(i,k+1)-paph(i,k))
+     .        *(pmfuq(i,k+1)-pmfuq(i,k)
+     .         +pmfdq(i,k+1)-pmfdq(i,k)
+     .          +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  220 CONTINUE
+  210 CONTINUE
+C
+      k = klev
+      DO 230 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .         *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k)
+     .           -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+         dt_con(i,k)=zdtdt
+         zdqdt=-RG/(paph(i,k+1)-paph(i,k))
+     .            *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)
+     .             +pdmfup(i,k)+pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  230 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu,
+     .     ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd,
+     .     pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+C
+C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+C FOR MASSFLUX CUMULUS PARAMETERIZATION
+C
+C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+C AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+C
+C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+C MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev)
+      REAL pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+      REAL ptu(klon,klev), pqu(klon,klev)
+      REAL pmfub(klon)
+      REAL prfl(klon)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      INTEGER  kcbot(klon), kctop(klon), kdtop(klon)
+      LOGICAL  ldcum(klon), lddraf(klon)
+C
+      REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon)
+      REAL zttest, zqtest, zbuo, zmftop
+      LOGICAL  llo2(klon)
+      INTEGER i, k, is, icall
+C----------------------------------------------------------------------
+      DO i= 1, klon
+         lddraf(i)=.FALSE.
+         kdtop(i)=klev+1
+      ENDDO
+C
+C----------------------------------------------------------------------
+C DETERMINE LEVEL OF FREE SINKING BY
+C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+C
+C FOR EVERY POINT AND PROCEED AS FOLLOWS:
+C     (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+C     (2) DO MIXING WITH CUMULUS CLOUD AIR
+C     (3) CHECK FOR NEGATIVE BUOYANCY
+C
+C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+C EVAPORATION OF RAIN AND CLOUD WATER)
+C----------------------------------------------------------------------
+C
+      DO 290 k = 3, klev-3
+C
+      is=0
+      DO 212 i= 1, klon
+         ztenwb(i,k)=ptenh(i,k)
+         zqenwb(i,k)=pqenh(i,k)
+         llo2(i) = ldcum(i).AND.prfl(i).GT.0.
+     .             .AND..NOT.lddraf(i)
+     .             .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i))
+         IF ( llo2(i) ) is = is + 1
+  212 CONTINUE
+      IF(is.EQ.0) GO TO 290
+C
+      icall=2
+      CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+C
+C----------------------------------------------------------------------
+C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+C AND CHECK FOR NEGATIVE BUOYANCY.
+C THEN SET VALUES FOR DOWNDRAFT AT LFS.
+C----------------------------------------------------------------------
+      DO 222 i= 1, klon
+      IF (llo2(i)) THEN
+         zttest=0.5*(ptu(i,k)+ztenwb(i,k))
+         zqtest=0.5*(pqu(i,k)+zqenwb(i,k))
+         zbuo=zttest*(1.+RETV*zqtest)-
+     .        ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         zcond(i)=pqenh(i,k)-zqenwb(i,k)
+         zmftop=-CMFDEPS*pmfub(i)
+         IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN
+            kdtop(i)=k
+            lddraf(i)=.TRUE.
+            ptd(i,k)=zttest
+            pqd(i,k)=zqtest
+            pmfd(i,k)=zmftop
+            pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfd(i,k)*pqd(i,k)
+            pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i)
+            prfl(i)=prfl(i)+pdmfdp(i,k-1)
+         ENDIF
+      ENDIF
+  222 CONTINUE
+c
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl,
+     .           ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp,
+     .           lddraf, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+C
+C          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+C          (I.E. T,Q,U AND V AND FLUXES)
+C
+C          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+C          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+C          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+C
+C          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+C          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+C          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+C
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon)
+      LOGICAL lddraf(klon)
+C
+      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
+      LOGICAL llo2(klon), llo1
+      INTEGER i, k, is, icall, itopde
+      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+      REAL zbuo
+C----------------------------------------------------------------------
+C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+C       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+C           LINEAR DECREASE OF MASSFLUX IN PBL
+C       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+C           AND MOISTENING IS CALCULATED IN *flxadjtq*
+C       (C) CHECKING FOR NEGATIVE BUOYANCY AND
+C           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+C
+      DO 180 k = 3, klev
+c
+      is = 0
+      DO i = 1, klon
+         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
+         IF (llo2(i)) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 180
+c
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/
+     .           (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
+         pen_d(i,k) = zentr
+         pde_d(i,k) = zentr
+      ENDIF
+      ENDDO
+c
+      itopde = klev-2
+      IF (k.GT.itopde) THEN
+         DO i = 1, klon
+         IF (llo2(i)) THEN
+            pen_d(i,k)=0.
+            pde_d(i,k)=pmfd(i,itopde)*
+     .      (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
+         ENDIF
+         ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
+         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
+         zqeen = pqenh(i,k-1)*pen_d(i,k)
+         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
+         zqdde = pqd(i,k-1)*pde_d(i,k)
+         zmfdsk = pmfds(i,k-1)+zseen-zsdde
+         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
+         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
+         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))-
+     .               pgeoh(i,k))/RCPD
+         ptd(i,k) = MIN(400.,ptd(i,k))
+         ptd(i,k) = MAX(100.,ptd(i,k))
+         zcond(i) = pqd(i,k)
+      ENDIF
+      ENDDO
+C
+      icall = 2
+      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zcond(i) = zcond(i)-pqd(i,k)
+         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))-
+     .          ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
+         IF (.not.llo1) pmfd(i,k) = 0.0
+         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
+         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
+         zdmfdp = -pmfd(i,k)*zcond(i)
+         pdmfdp(i,k-1) = zdmfdp
+         prfl(i) = prfl(i)+zdmfdp
+      ENDIF
+      ENDDO
+c
+  180 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Objet: ajustement entre T et Q
+c======================================================================
+C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+C        kcall=0    ENV. T AND QS IN*CUINI*
+C        kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL ldflag(klon)
+      INTEGER kcall
+c
+      REAL zcond(klon), zcond1
+      REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      z5alvcp = r5les*RLVTT/RCPD
+      z5alscp = r5ies*RLSTT/RCPD
+      zalvdcp = rlvtt/RCPD
+      zalsdcp = rlstt/RCPD
+C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
+      DO 210 i =1, klon
+      IF (ldflag(i)) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond(i) = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor))
+         IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.)
+         IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.)
+         pt(i) = pt(i) + zldcp*zcond(i)
+         pq(i) = pq(i) - zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i =1, klon
+         IF (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(ldflag(i).AND.zcond(i).NE.0.) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond1 = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor))
+         pt(i) = pt(i) + zldcp*zcond1
+         pq(i) = pq(i) - zcond1
+      ENDIF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxsetup
+      IMPLICIT none
+C
+C     THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+C
+#include "YOECUMF.h"
+C
+      ENTRPEN=1.0E-4  ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+      ENTRSCV=3.0E-4  ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+      ENTRMID=1.0E-4  ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+      ENTRDD =2.0E-4  ! ENTRAINMENT RATE FOR DOWNDRAFTS
+      CMFCTOP=0.33  ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+      CMFCMAX=1.0  ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+      CMFCMIN=1.E-10  ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+      CMFDEPS=0.3  ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+      CPRCON =2.0E-4  ! CONVERSION FROM CLOUD WATER TO RAIN
+      RHCDD=1.  ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+c                 (FORMULATION IMPLIES SATURATION)
+      LMFPEN = .TRUE.
+      LMFSCV = .TRUE.
+      LMFMID = .TRUE.
+      LMFDD = .TRUE.
+      LMFDUDV = .TRUE.
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/conlmd.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/conlmd.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/conlmd.F	(revision 984)
@@ -0,0 +1,2321 @@
+!
+! $Header$
+!
+      SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q,
+     s                   d_t, d_q, rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection utilis'e dans le modele du LMD
+c        Ajustement humide (Manabe) + Ajustement convectif (Kuo)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql(klon,klev), d_ql_bis(klon,klev)
+      REAL rneb(klon,klev), rneb_bis(klon,klev)
+c
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+ccc      CALL fiajh ! ancienne version de Convection Manabe
+      CALL conman ! nouvelle version de Convection Manabe
+     e     (dtime, paprs, pplay, t, q,
+     s      d_t, d_q, d_ql, rneb,
+     s      rain, snow, ibas, itop)
+c
+      IF (usekuo) THEN
+ccc      CALL fiajc ! ancienne version de Convection Kuo
+      CALL conkuo ! nouvelle version de Convection Kuo
+     e     (dtime, paprs, pplay, t, q, conv_q,
+     s      d_t_bis, d_q_bis, d_ql_bis, rneb_bis, 
+     s      rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+         d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         ibas(i) = MIN(ibas(i),ibas_bis(i))
+         itop(i) = MAX(itop(i),itop_bis(i))
+      ENDDO
+      ENDIF
+c
+c L'eau liquide convective est dispersee dans l'air:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE conman (dtime, paprs, pplay, t, q,
+     s                   d_t, d_q, d_ql, rneb,
+     s                   rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
+c Objet: ajustement humide convectif avec la possibilite de faire
+c        l'ajustement sur une fraction de la maille.
+c Methode: On impose une distribution uniforme pour la vapeur d'eau
+c au sein d'une maille. On applique la procedure d'ajustement
+c successivement a la totalite, 75%, 50%, 25% et 5% de la maille
+c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
+c les activites convectives et corrige le biais "trop froid et sec"
+c du modele.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL afaire(klon)   ! .TRUE. implique l'ajustement
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
+c
+      INTEGER nb ! nombre de sous-fractions a considere
+      PARAMETER (nb=1)
+ccc      PARAMETER (nb=3)
+c
+      REAL ratqs ! largeur de la distribution pour vapeur d'eau
+      PARAMETER (ratqs=0.05)
+c
+      REAL w_q(klon,klev)
+      REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev)
+      REAL w_rneb(klon,klev)
+      REAL w_rain(klon), w_snow(klon)
+      INTEGER w_ibas(klon), w_itop(klon)
+      REAL zq1, zq2
+      INTEGER i, k, n
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL zdp1, zdp2
+      REAL zqs1, zqs2, zdqs1, zdqs2
+      REAL zgamdz
+      REAL zflo ! flotabilite
+      REAL zsat ! sur-saturation
+      REAL zdelta, zcor, zcvm5
+      LOGICAL imprim
+c
+      INTEGER ncpt
+      SAVE ncpt
+c$OMP THREADPRIVATE(ncpt)
+      REAL frac(nb) ! valeur de la maille fractionnelle
+      SAVE frac
+c$OMP THREADPRIVATE(frac)
+      INTEGER opt_cld(nb) ! option pour le modele nuageux
+      SAVE opt_cld
+c$OMP THREADPRIVATE(opt_cld)
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA frac / 1.0 /
+      DATA opt_cld / 4 /
+ccc      DATA frac    / 1.0, 0.50, 0.25/
+ccc      DATA opt_cld / 4,   4,    4/
+c
+      DATA appel1er /.TRUE./
+      DATA ncpt /0/
+c
+      IF (appel1er) THEN
+         PRINT*, 'conman, nb:', nb
+         PRINT*, 'conman, frac:', frac
+         PRINT*, 'conman, opt_cld:', opt_cld
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c S'il n'y a pas d'instabilite conditionnelle,
+c pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         afaire(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev-1
+      DO i = 1, klon
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+            zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+            zqs1=MIN(0.5,zqs1)
+            zcor=1./(1.-RETV*zqs1)
+            zqs1=zqs1*zcor
+            zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor)
+c
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1))
+            zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1)
+            zqs2=MIN(0.5,zqs2)
+            zcor=1./(1.-RETV*zqs2)
+            zqs2=zqs2*zcor
+            zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor)
+         ELSE
+           IF (t(i,k) .LT. t_coup) THEN
+              zqs1= qsats(t(i,k)) / pplay(i,k)
+              zdqs1= dqsats(t(i,k),zqs1)
+c
+              zqs2= qsats(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsats(t(i,k+1),zqs2)
+           ELSE
+              zqs1= qsatl(t(i,k)) / pplay(i,k)
+              zdqs1= dqsatl(t(i,k),zqs1)
+c
+              zqs2= qsatl(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsatl(t(i,k+1),zqs2)
+           ENDIF
+         ENDIF
+         zdp1 = paprs(i,k) - paprs(i,k+1)
+         zdp2 = paprs(i,k+1) - paprs(i,k+2)
+         zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(t(i,k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)
+     .            +RLVTT*(zqs1*zdp1+zqs2*zdp2)/(zdp1+zdp2)
+     .           ) / (1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2) )
+         zflo = t(i,k) + zgamdz - t(i,k+1)
+         zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
+         IF (zflo.GT.0.0) afaire(i) = .TRUE.
+c erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
+      ENDDO
+      ENDDO
+c
+      imprim = MOD(ncpt,48).EQ.0
+      DO 99999 n = 1, nb
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zq1 = q(i,k) * (1.0-ratqs)
+         zq2 = q(i,k) * (1.0+ratqs)
+         w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      CALL conmanv (dtime, paprs, pplay, t, w_q,
+     e              afaire, opt_cld(n),
+     s              w_d_t, w_d_q, w_d_ql, w_rneb,
+     s              w_rain, w_snow, w_ibas, w_itop,accompli,imprim)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         d_t(i,k) = w_d_t(i,k) * frac(n)
+         d_q(i,k) = w_d_q(i,k) * frac(n)
+         d_ql(i,k) = w_d_ql(i,k) * frac(n)
+         IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n)
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         rain(i) = w_rain(i) * frac(n)
+         snow(i) = w_snow(i) * frac(n)
+         ibas(i) = MIN(ibas(i),w_ibas(i))
+         itop(i) = MAX(itop(i),w_itop(i))
+      ENDIF
+      ENDDO
+      DO i = 1, klon
+         IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
+      ENDDO
+c
+99999 CONTINUE
+c
+      ncpt = ncpt + 1
+c
+      RETURN
+      END
+      SUBROUTINE conmanv (dtime, paprs, pplay, t, q,
+     e                    afaire, opt_cld,
+     s                    d_t, d_q, d_ql, rneb,
+     s                    rain, snow, ibas, itop,accompli,imprim)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement humide (convection proposee par Manabe).
+c        Pour une colonne verticale, il peut avoir plusieurs blocs
+c        necessitant l'ajustement. ibas est le bas du plus bas bloc
+c        et itop est le haut du plus haut bloc
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
+      LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
+c
+c Quelques options:
+c
+      LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
+      PARAMETER (new_top=.FALSE.)
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+      LOGICAL old_tau ! implique precip nulle, si vrai.
+      PARAMETER (old_tau=.FALSE.)
+      REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+      REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+      PARAMETER (dpmin=0.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
+      LOGICAL exigent ! implique un calcul supplementaire pour Qs
+      PARAMETER (exigent=.FALSE.)
+c
+      INTEGER kbase
+      PARAMETER (kbase=0)
+c
+c Variables locales:
+c
+      INTEGER nexpo
+      INTEGER i, k, k1min, k1max, k2min, k2max, is
+      REAL zgamdz(klon,klev-1)
+      REAL zt(klon,klev), zq(klon,klev)
+      REAL zqs(klon,klev), zdqs(klon,klev)
+      REAL zqmqsdp(klon,klev)
+      REAL ztnew(klon,klev), zqnew(klon,klev)
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zsat(klon) ! sur-saturation
+      REAL zflo(klon) ! flotabilite
+      REAL za(klon), zb(klon), zc(klon)
+      INTEGER k1(klon), k2(klon)
+      REAL zdelta, zcor, zcvm5
+      REAL delp(klon,klev)
+      LOGICAL possible(klon), todo(klon), etendre(klon)
+      LOGICAL aller(klon), todobis(klon)
+      REAL zalfa
+      INTEGER nbtodo, nbdone
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k) - paprs(i,k+1)
+      ENDDO
+      ENDDO
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+         accompli(i) = .FALSE.
+      ENDDO
+c
+c Preparations
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zt(i,k) = t(i,k)
+         zq(i,k) = q(i,k) 
+c
+c        Calculer Qs et L/Cp*dQs/dT
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+c
+c        Calculer (q-qs)*dp
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c-----zgama is the moist convective lapse rate (-dT/dz).
+c-----zgamdz(*,k) est la difference minimale autorisee des temperatures
+c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
+c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c On cherche la presence simultanee d'instabilite conditionnelle
+c et de sur-saturation. Sinon, pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (possible(i)) THEN
+         k1(i) = kbase
+         k2(i) = k1(i) + 1
+      ENDIF
+      ENDDO
+c
+  810 CONTINUE ! chercher le bas de la colonne a ajuster
+c
+      k2min = klev
+      DO i = 1, klon
+         todo(i) = .FALSE.
+         aller(i) = .TRUE.
+         IF (possible(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.EQ.klev) GOTO 860
+      DO k = k2min, klev-1
+      DO i = 1, klon
+      IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            k1(i) = k
+            k2(i) = k+1
+            todo(i) = .TRUE.
+            aller(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (possible(i).AND.aller(i)) THEN
+         todo(i) = .FALSE.
+         k1(i) = klev
+         k2(i) = klev
+      ENDIF
+      ENDDO
+c
+CCC      DO i = 1, klon
+CCC      IF (possible(i)) THEN
+CCC  811    k2(i) = k2(i) + 1
+CCC         IF (k2(i) .GT. klev) THEN
+CCC            todo(i) = .FALSE.
+CCC            GOTO 812
+CCC         ENDIF
+CCC         k = k2(i)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
+CCC         k1(i) = k2(i) - 1
+CCC         todo(i) = .TRUE.
+CCC      ENDIF
+CCC  812 CONTINUE
+CCC      ENDDO
+c
+  820 CONTINUE ! chercher le haut de la colonne
+c
+      k2min = klev
+      DO i = 1, klon
+         aller(i) = .TRUE.
+         IF (todo(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.LT.klev) THEN
+      DO k = k2min, klev
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN
+            zsat(i) = zsat(i) + zqmqsdp(i,k)
+            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+            IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+               aller(i) = .FALSE.
+            ELSE
+               k2(i) = k
+            ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c error      is = 0
+c error      DO i = 1, klon
+c error      IF(todo(i).AND.aller(i)) THEN
+c error         is = is + 1
+c error         todo(i) = .FALSE.
+c error         k2(i) = klev
+c error      ENDIF
+c error      ENDDO
+c error      IF (is.GT.0) THEN
+c error         PRINT*, "Bizard. je pourrais continuer mais j arrete"
+c error         CALL abort
+c error      ENDIF
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (todo(i)) THEN
+CCC  821    CONTINUE
+CCC         IF (k2(i) .EQ. klev) GOTO 822
+CCC         k = k2(i) + 1
+CCC         zsat(i) = zsat(i) + zqmqsdp(i,k)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
+CCC         k2(i) = k
+CCC         GOTO 821
+CCC      ENDIF
+CCC  822 CONTINUE
+CCC      ENDDO
+c
+  830 CONTINUE ! faire l'ajustement en sachant k1 et k2
+c
+      is = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (k2(i).LE.k1(i)) is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         PRINT*, "Impossible: k1 trop grand ou k2 trop petit"
+         PRINT*, "is=", is
+         CALL abort
+      ENDIF
+c
+      k1min = klev
+      k1max = 1
+      k2max = 1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k1min = MIN(k1min,k1(i))
+         k1max = MAX(k1max,k1(i))
+         k2max = MAX(k2max,k2(i))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      k = k1(i)
+      za(i) = 0.
+      zb(i) = ( RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .      -RLVTT*(zqs(i,k)-zq(i,k)) )*delp(i,k)
+      zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         za(i) = za(i) + zgamdz(i,k-1)
+         zb(i) = zb(i)+(RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .           -RLVTT*(zqs(i,k)-zq(i,k)) ) * delp(i,k)
+         zc(i) = zc(i) + delp(i,k)*RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k = k1(i)
+         ztnew(i,k) = zb(i)/zc(i)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                          *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                        *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Quantite de condensation produite pendant l'ajustement:
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         rneb(i,k) = 1.0
+         zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Si condensation negative, effort completement perdu:
+c
+      DO i = 1, klon
+         IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE.
+      ENDDO
+c
+c L'ajustement a ete accompli, meme les calculs accessoires
+c ne sont pas encore faits:
+c
+      DO i = 1, klon
+         IF (todo(i)) accompli(i) = .TRUE.
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1))
+     .                 /paprs(i,1)-dpmin)
+     .                 *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+      ENDIF
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de 
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+            zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k)
+         ENDIF
+         ENDDO
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .      zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k)) 
+     .                          * delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND.
+     .       zvapo(i).GT.0.0)
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,zq(i,k)-zqnew(i,k))
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse 
+         ENDDO                       ! (avec ponderation)
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k) / RG
+     .                    * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre evaporee:
+c
+      zalfa = 0.05
+      IF (evap_prec .AND. (k1max.GE.2)) THEN
+      DO k = k1max-1, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa )
+         zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .         * delp(i,k)/pplay(i,k)*zt(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k)
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime
+         zq(i,k) = zq(i,k) - (zrfln-zrfl(i)) 
+     .                     * (RG/(delp(i,k)))*dtime
+         zt(i,k) = zt(i,k) + (zrfln-zrfl(i))
+     .                     * (RG/(delp(i,k)))*dtime
+     .                     * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k))
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (zt(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+c Mise a jour de la temperature et de l'humidite
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         zt(i,k) = ztnew(i,k)
+         zq(i,k) = zqnew(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Re-calculer certaines variables pour etendre et re-ajuster la colonne
+c
+      IF (exigent) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (exigent) THEN
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Verifier si l'on peut etendre le bas de la colonne
+c
+      DO i = 1, klon
+         etendre(i) = .FALSE.
+      ENDDO
+c
+      k1max = 1
+      DO i = 1, klon
+      IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN
+         k = k1(i)
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+csc voici l'ancienne ligne:
+csc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+csc sylvain: il faut RESPECTER les 2 criteres:
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            etendre(i) = .TRUE.
+            k1(i) = k1(i) - 1
+            k1max = MAX(k1max,k1(i))
+            aller(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+c
+      IF (k1max.GT.(kbase+1)) THEN
+      DO k = k1max, kbase+1, -1
+      DO i = 1, klon
+      IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN
+         zsat(i) = zsat(i) + zqmqsdp(i,k)
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN
+            aller(i) = .FALSE.
+         ELSE
+            k1(i) = k
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (etendre(i).AND.aller(i)) THEN
+            k1(i) = 1
+         ENDIF
+      ENDDO
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (etendre(i)) THEN
+CCC  840    k = k1(i)
+CCC         IF (k.GT.1) THEN
+CCC            zsat(i) = zsat(i) + zqmqsdp(i,k-1)
+CCC            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC            IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+CCC               k1(i) = k - 1
+CCC               GOTO 840
+CCC            ENDIF
+CCC         ENDIF
+CCC      ENDIF
+CCC      ENDDO
+c
+      DO i = 1, klon
+         todobis(i) = todo(i)
+         todo(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (etendre(i)) THEN
+         todo(i) = .TRUE.
+         is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         IF (new_top) THEN
+            GOTO 820 ! chercher de nouveau le sommet k2
+         ELSE
+            GOTO 830 ! supposer que le sommet est celui deja trouve
+         ENDIF
+      ENDIF
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (todobis(i) .AND. k2(i).LT.klev) THEN
+         is = is + 1
+         possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks 
+c     a ajuster a partir du sommet de la colonne precedente
+c
+  860 CONTINUE ! Calculer les tendances et diagnostiques
+ccc      print*, "Apres 860"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (accompli(i)) THEN
+         d_t(i,k) = zt(i,k) - t(i,k)
+         zq(i,k) = MAX(zq(i,k),seuil_vap)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 888 i = 1, klon
+      IF (accompli(i)) THEN
+         DO k = 1, klev
+         IF (rneb(i,k).GT.0.0) THEN
+            ibas(i) = k
+            GOTO 807
+         ENDIF
+         ENDDO
+  807    CONTINUE
+         DO k = klev, 1, -1
+         IF (rneb(i,k).GT.0.0) THEN
+            itop(i) = k
+            GOTO 808
+         ENDIF
+         ENDDO
+  808    CONTINUE
+      ENDIF
+  888 CONTINUE
+c
+      IF (imprim) THEN
+         nbtodo = 0
+         nbdone = 0
+         DO i = 1, klon
+            IF (afaire(i)) nbtodo = nbtodo + 1
+            IF (accompli(i)) nbdone = nbdone + 1
+         ENDDO
+         PRINT*, "nbTodo, nbDone=", nbtodo, nbdone
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s                  d_t, d_q, d_ql, rneb, 
+     s                  rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection de type Kuo (1965).
+c        Cette version du code peut calculer le niveau de depart
+c N.B. version vectorielle (le 6 oct. 1997)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime               ! intervalle du temps (s)
+      REAL paprs(klon,klev+1)  ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)    ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)        ! temperature (K)
+      REAL q(klon,klev)        ! humidite specifique
+      REAL conv_q(klon,klev)   ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)      ! incrementation temperature
+      REAL d_q(klon,klev)      ! incrementation humidite
+      REAL d_ql(klon,klev)     ! incrementation eau liquide
+      REAL rneb(klon,klev)     ! nebulosite
+      REAL rain(klon)          ! pluies (mm/s)
+      REAL snow(klon)          ! neige (mm/s)
+      INTEGER itop(klon)       ! niveau du sommet
+      INTEGER ibas(klon)       ! niveau du bas
+c
+      LOGICAL ldcum(klon)      ! convection existe
+      LOGICAL todo(klon)
+c
+c Quelsques options:
+c
+      LOGICAL calcfcl ! calculer le niveau de convection libre
+      PARAMETER (calcfcl=.TRUE.)
+      INTEGER ldepar ! niveau fixe de convection libre
+      PARAMETER (ldepar=4)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      LOGICAL new_deh ! nouvelle facon de calculer dH
+      PARAMETER (new_deh=.FALSE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      LOGICAL old_tau ! implique precipitation nulle
+      PARAMETER (old_tau=.FALSE.)
+      REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+      REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+      PARAMETER (dpmin=0.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
+c
+c Variables locales:
+c
+      INTEGER nexpo
+      LOGICAL nuage(klon)
+      INTEGER i, k, kbmin, kbmax, khmax
+      REAL ztotal(klon,klev), zdeh(klon,klev)
+      REAL zgz(klon,klev)
+      REAL zqs(klon,klev)
+      REAL zdqs(klon,klev)
+      REAL ztemp(klon,klev)
+      REAL zpres(klon,klev)
+      REAL zconv(klon) ! convergence d'humidite
+      REAL zvirt(klon) ! convergence virtuelle d'humidite
+      REAL zfrac(klon) ! fraction convective
+      INTEGER kb(klon), kh(klon)
+c
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zdelta, zcvm5, zcor
+      REAL zvar
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c Fonctions thermodynamiques
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         PRINT*, 'conkuo, calcfcl:', calcfcl
+         IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar
+         PRINT*, 'conkuo, opt_cld:', opt_cld
+         PRINT*, 'conkuo, evap_prec:', evap_prec
+         PRINT*, 'conkuo, new_deh:', new_deh
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (t(i,k).LT.t_coup) THEN
+              zqs(i,k) = qsats(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsats(t(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsatl(t(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer gz (energie potentielle)
+c
+      DO i = 1, klon
+         zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                   * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgz(i,k) = zgz(i,k-1)
+     .            + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                 * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+c Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztotal(i,k) = RCPD*t(i,k) + RLVTT*zqs(i,k) + zgz(i,k)
+      ENDDO
+      ENDDO
+c
+c Determiner le niveau de depart et calculer la difference de
+c l'energie statique humide saturee (ztotal) entre la couche
+c de depart et chaque couche au-dessus.
+c
+      IF (calcfcl) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            zpres(i,k) = pplay(i,k)
+            ztemp(i,k) = t(i,k)
+         ENDDO
+         ENDDO
+         CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            k = kb(i)
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDIF
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+         IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN
+            IF (new_deh) THEN
+               zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+            ELSE
+               zdeh(i,k) = zdeh(i,k-1)
+     .                   + RCPD * (t(i,k-1)-t(i,k))
+     .                   - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                        *(pplay(i,k-1)-pplay(i,k))
+     .                   + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+         ENDIF
+         ENDDO
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            k = ldepar
+            kb(i) = ldepar
+            ldcum(i) = .TRUE.
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDDO
+         DO k = ldepar+1, klev
+         DO i = 1, klon
+         IF (new_deh) THEN
+             zdeh(i,k)  = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+         ELSE
+             zdeh(i,k) = zdeh(i,k-1)
+     .                 + RCPD * (t(i,k-1)-t(i,k))
+     .                 - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                      *(pplay(i,k-1)-pplay(i,k))
+     .                 + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c-----Chercher le sommet du nuage
+c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
+c-----psolpa/RG pres) du bas jusqu'au sommet du nuage.
+c-----Calculer la convergence virtuelle pour que toute la maille 
+c-----deviennt nuageuse (du bas jusqu'au sommet du nuage)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (k.GE.kb(i) .AND. ldcum(i)) THEN
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i) = k
+            zconv(i)=zconv(i)+conv_q(i,k)*dtime
+     .                       *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0
+      ENDDO
+c
+      kbmin = klev
+      kbmax = 0
+      khmax = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         kbmin = MIN(kbmin,kb(i))
+         kbmax = MAX(kbmax,kb(i))
+         khmax = MAX(khmax,kh(i))
+      ENDIF
+      ENDDO
+c
+c-----Calculer la surface couverte par le nuage
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0))
+      ENDIF
+      ENDDO
+c
+c-----Calculs essentiels:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zcond(i) = 0.0
+      ENDIF
+      ENDDO
+      DO k = kbmin, khmax
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+         zvar = zdeh(i,k)/(1.+zdqs(i,k))
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG
+         rneb(i,k) = zfrac(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i) .AND. zcond(i).LT.0.0) THEN
+         PRINT*, 'WARNING: cond. negative (Kuo) ',
+     .            i,kb(i),kh(i), zcond(i)
+         zcond(i) = 0.0
+         DO k = kb(i), kh(i)
+            d_t(i,k) = 0.0
+            d_q(i,k) = 0.0
+         ENDDO
+         todo(i) = .FALSE. ! effort totalement perdu
+      ENDIF
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1))
+     .               /paprs(i,1)-dpmin)
+     .             *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+      ENDIF
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k))
+     .                    * (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND.
+     .                     zvapo(i).GT.0.0) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,-d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG
+     .                    * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre re-evaporee:
+c
+      IF (evap_prec .AND. kbmax.GE.2) THEN
+      DO k = kbmax, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) )
+         zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .       * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*t(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                 /RG/dtime
+         d_q(i,k) = - (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         d_t(i,k) = (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .          * RLVTT/RCPD
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (t(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: calculer le niveau de convection libre
+c        (FCL: Free Convection Level)
+c======================================================================
+c Arguments:
+c pt---input-R- temperature (K)
+c pq---input-R- vapeur d'eau (kg/kg)
+c pg---input-R- geopotentiel (g*z ou z est en metre)
+c pp---input-R- pression (Pa)
+c
+c LDCUM---output-L- Y-t-il la convection
+c kcbot---output-I- Niveau du bas de la convection
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev)
+      INTEGER  kcbot(klon)
+      LOGICAL  LDCUM(klon)
+C
+      REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev)
+      REAL zqold(klon), zbuo
+      INTEGER is, i, k
+c
+c klab=1: on est sous le nuage convectif
+c klab=2: le bas du nuage convectif
+c klab=0: autres couches
+      INTEGER klab(klon,klev)
+c
+c quand lflag=.true., on est sous le nuage, il faut donc appliquer
+c le processus d'elevation.
+      LOGICAL lflag(klon)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         ztu(i,k) = pt(i,k)
+         zqu(i,k) = pq(i,k)
+         zlu(i,k) = 0.0
+         klab(i,k) = 0
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,1)=1
+         kcbot(i)=2
+         LDCUM(i)=.FALSE.
+      ENDDO
+C
+      DO 290 k = 2, klev-1
+c
+      is=0
+      DO i = 1, klon
+         if (klab(i,k-1).EQ.1) is = is + 1
+         lflag(i) = .FALSE.
+         if (klab(i,k-1).EQ.1) lflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+c on eleve le parcel d'air selon l'adiabatique sec
+c
+      DO i = 1, klon
+      IF (lflag(i)) THEN
+         zqu(i,k) = zqu(i,k-1)
+         ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k)=1
+         zqold(i) = zqu(i,k)
+      ENDIF
+      ENDDO
+c
+c on calcule la condensation eventuelle
+c
+      CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
+c
+c s'il y a la condensation et la "buoyancy" force est positive
+c c'est bien le bas de la tour de convection
+c
+      DO i=1, klon
+      IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k)
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) THEN
+            kcbot(i) = k
+            LDCUM(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+C
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: ajustement entre T et Q
+c======================================================================
+c Arguments:
+c pp---input-R- pression (Pa)
+c pt---input/output-R- temperature (K)
+c pq---input/output-R- vapeur d'eau (kg/kg)
+c======================================================================
+C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+C
+C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+C        KCALL=0    ENV. T AND QS IN*CUINI*
+C        KCALL=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL  ldflag(klon)
+      INTEGER KCALL
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zcond(klon), zcond1
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+C
+      DO 210 i=1, klon
+      IF (LDFLAG(i)) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond(i)=(pq(i)-zqsat) / (1. + zdqsat)
+         IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.)
+         IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.)
+         pt(i)=pt(i)+zldcp*zcond(i)
+         pq(i)=pq(i)-zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i=1, klon
+         if (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF(is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond1=(pq(i)-zqsat) / (1.+zdqsat)
+         pt(i)=pt(i)+zldcp*zcond1
+         pq(i)=pq(i)-zcond1
+      END IF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE fiajh(dtime, paprs, pplay, t, q,
+     .                 d_t, d_q, d_ql, rneb,
+     .                 rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT NONE
+c
+c Ajustement humide (Schema de convection de Manabe)
+C.
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime        ! intervalle du temps (s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL d_q(klon,klev) ! incrementation pour vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+c
+      REAL rain(klon)    ! variable non utilisee
+      REAL snow(klon)    ! variable non utilisee
+      INTEGER ibas(klon) ! variable non utilisee
+      INTEGER itop(klon) ! variable non utilisee
+
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+c
+c Variables locales:
+c 
+      INTEGER i, k
+      INTEGER k1, k1p, k2, k2p
+      LOGICAL itest(klon)
+      REAL delta_q(klon, klev)
+      REAL cp_new_t(klev)
+      REAL cp_delta_t(klev)
+      REAL new_qb(klev)
+      REAL v_cptj(klev), v_cptjk1, v_ssig
+      REAL v_cptt(klon,klev), v_p, v_t
+      REAL v_qs(klon,klev), v_qsd(klon,klev)
+      REAL zq1(klon), zq2(klon)
+      REAL gamcpdz(klon,2:klev)
+      REAL zdp, zdpm
+c
+      REAL zsat ! sur-saturation
+      REAL zflo ! flotabilite
+c
+      REAL local_q(klon,klev),local_t(klon,klev)
+c
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         local_q(i,k) = q(i,k)
+         local_t(i,k) = t(i,k)
+         rneb(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer v_qs et v_qsd:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer Gamma * Cp * dz: (gamm est le gradient critique)
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zdpm = paprs(i,k-1)-paprs(i,k)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * 
+     .                      (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) * 
+     .                      (v_qs(i,k-1)*zdpm + v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+
+     .                        v_qsd(i,k)*zdp)/(zdpm+zdp) )
+      ENDDO
+      ENDDO
+C
+C------------------------------------ modification des profils instables
+      DO 9999 i = 1, klon
+      itest(i) = .FALSE.
+C
+      k1 = 0
+      k2 = 1
+C
+  810 CONTINUE ! chercher k1, le bas de la colonne
+      k2 = k2 + 1
+      IF (k2 .GT. klev) GOTO 9999
+      zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2)
+      zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2))
+     .    +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
+      IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810
+      k1 = k2 - 1
+      itest(i) = .TRUE.
+C
+  820 CONTINUE ! chercher k2, le haut de la colonne
+      IF (k2 .EQ. klev) GOTO 821
+      k2p = k2 + 1
+      zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1))
+     .          *(local_q(i,k2p)-v_qs(i,k2p))
+      zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p)
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821
+      k2 = k2p
+      GOTO 820
+  821 CONTINUE
+C
+C------------------------------------------------------ ajustement local
+  830 CONTINUE ! ajustement proprement dit
+      v_cptj(k1) = 0.0
+      zdp = paprs(i,k1)-paprs(i,k1+1)
+      v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))
+     .               + RLVTT*(local_q(i,k1)-v_qs(i,k1)) ) * zdp
+      v_ssig = zdp * (1.0+v_qsd(i,k1))
+C
+      k1p = k1 + 1
+      DO k = k1p, k2
+         zdp = paprs(i,k)-paprs(i,k+1)
+         v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k)
+         v_cptjk1 = v_cptjk1 + zdp
+     .             * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k))
+     .               + RLVTT*(local_q(i,k)-v_qs(i,k)) )
+         v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k))
+      ENDDO
+C
+      DO k = k1, k2
+         cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
+         cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k)
+         new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT
+         local_q(i,k) = new_qb(k)
+         local_t(i,k) = cp_new_t(k) / RCPD
+      ENDDO
+C
+C--------------------------------------------------- sondage vers le bas
+C              -- on redefinit les variables prognostiques dans
+C              -- la colonne qui vient d'etre ajustee
+C
+      DO k = k1, k2
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+C
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      DO k = 2, klev
+         zdpm = paprs(i,k-1) - paprs(i,k)
+         zdp = paprs(i,k) - paprs(i,k+1)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) *
+     .                      (v_cptt(i,k-1)*zdpm+v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) *
+     .                      (v_qs(i,k-1)*zdpm+v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+v_qsd(i,k)*zdp)
+     .                      /(zdpm+zdp) )
+      ENDDO
+C
+C Verifier si l'on peut etendre la colonne vers le bas
+C
+      IF (k1 .EQ. 1) GOTO 841 ! extension echouee
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
+     .   + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee
+C
+  840 CONTINUE
+      k1 = k1 - 1
+      IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))
+     .             *(paprs(i,k1-1)-paprs(i,k1))
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN
+         GOTO 840
+      ELSE
+         GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      ENDIF
+  841 CONTINUE
+C
+      GOTO 810 ! chercher d'autres blocks en haut
+C
+ 9999 CONTINUE ! boucle sur tous les points
+C-----------------------------------------------------------------------
+c
+c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
+c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         delta_q(i,k) = local_q(i,k) - q(i,k)
+         IF (delta_q(i,k).LT.0.) rneb(i,k)  = 1.0
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
+c l'eau liquide est distribuee aux endroits ou la vapeur d'eau
+c diminue et d'une maniere proportionnelle a cet diminution):
+c
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zq1(i) = zq1(i) - delta_q(i,k) * zdp
+         zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp
+         ENDIF
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         IF (zq2(i).NE.0.0)
+     .      d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i)
+         ENDIF
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+          local_q(i, k) = MAX(local_q(i, k), seuil_vap)
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = local_t(i,k) - t(i,k)
+         d_q(i,k) = local_q(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE fiajc(dtime,paprs,pplay,
+     .                 t, q,conv_q,
+     .                 d_t, d_q, d_ql,rneb,
+     .                 rain, snow, ibas, itop)
+      USE dimphy
+      IMPLICIT NONE
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Options:
+c
+      INTEGER plb ! niveau de depart pour la convection
+      PARAMETER (plb=4)
+c
+c Mystere: cette option n'est pas innocente pour les resultats !
+c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
+      LOGICAL vector ! calcul vectorise
+      PARAMETER (vector=.FALSE.)
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Arguments:
+c
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL t(klon,klev) ! temperature (K)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+      REAL dtime ! intervalle du temps (s)
+      REAL conv_q(klon,klev) ! taux de convergence de l'humidite
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL rain(klon) ! variable non-utilisee
+      REAL snow(klon) ! variable non-utilisee
+      INTEGER itop(klon) ! variable non-utilisee
+      INTEGER ibas(klon) ! variable non-utilisee
+c
+      INTEGER kh(klon), i, k
+      LOGICAL nuage(klon), test(klon,klev)
+      REAL zconv(klon), zdeh(klon,klev), zvirt(klon)
+      REAL zdqs(klon,klev), zqs(klon,klev)
+      REAL ztt, zvar, zfrac(klon)
+      REAL zq1(klon), zq2(klon)
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+          rneb(i,k) = 0.0
+          d_ql(i,k) = 0.0
+          d_t(i,k) = 0.0
+          d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         itop(i) = 0
+         ibas(i) = 0
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Calculer Qs et L/Cp * dQs/dT:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztt = t(i,k)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-ztt))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (ztt .LT. t_coup) THEN
+              zqs(i,k) = qsats(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsats(ztt,zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsatl(ztt,zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Determiner la difference de l'energie totale saturee:
+c
+      DO i = 1, klon
+         k = plb
+         zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie
+      ENDDO
+      DO k = plb+1, klev
+      DO i = 1, klon
+      zdeh(i,k) = zdeh(i,k-1)
+     .             + RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+      ENDDO
+      ENDDO
+c
+c Determiner le sommet du nuage selon l'instabilite
+c Calculer les convergences d'humidite (reelle et virtuelle)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i)  = k
+            zconv(i) = zconv(i)+conv_q(i,k)*dtime
+     .                         *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      IF (vector) THEN
+c
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+         test(i,k) = .TRUE.
+         zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+      ELSE
+         test(i,k) = .FALSE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+         zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+         zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                   * (paprs(i,k)-paprs(i,k+1))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      ELSE ! (.NOT. vector)
+c
+      DO 999 i = 1, klon
+      IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+ccc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
+ccc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
+         zfrac(i)  = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+         DO k = plb, kh(i)
+            zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+            d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .               - conv_q(i,k)*dtime
+            d_t(i,k) = zvar * zfrac(i) / RCPD
+         ENDDO
+c
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         DO k = plb, kh(i)
+            IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+            zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+            zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                      * (paprs(i,k)-paprs(i,k+1))
+         ENDDO
+         DO k = plb, kh(i)
+            IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+         ENDDO
+      ENDIF
+  999 CONTINUE
+c
+      ENDIF ! fin de teste sur vector
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/convect1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/convect1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/convect1.F	(revision 984)
@@ -0,0 +1,649 @@
+!
+! $Header$
+!
+      subroutine convect1(len,nd,ndp1,noff,minorig,
+     &                   t,q,qs,u,v,
+     &                   p,ph,iflag,ft,
+     &                   fq,fu,fv,precip,cbmf,delt,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect1.f	1.1 04/21/00
+C                       19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect1
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect1(len,nd,noff,minorig,
+C    &                   t,q,qs,u,v,
+C    &                   p,ph,iflag,ft,
+C    &                   fq,fu,fv,precip,cbmf,delt)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      noff          Integer        Input        integer limit for convection (nd-noff)
+C      minorig       Integer        Input        First level of convection
+C      t             Real           Input        temperature
+C      q             Real           Input        specific hum
+C      qs            Real           Input        sat specific hum
+C      u             Real           Input        u-wind
+C      v             Real           Input        v-wind
+C      p             Real           Input        full level pressure
+C      ph            Real           Input        half level pressure
+C      iflag         Integer        Output       iflag on latitude strip
+C      ft            Real           Output       temp tend
+C      fq            Real           Output       spec hum tend
+C      fu            Real           Output       u-wind tend
+C      fv            Real           Output       v-wind tend
+C      cbmf          Real           In/Out       cumulus mass flux
+C      delt          Real           Input        time step
+C      iflag         Integer        Output       integer flag for Emanuel conditions
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         convect2        Emanuel cumulus convection tendency calculations
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+       USE dimphy
+      implicit none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      real t(len,nd)
+      real q(len,nd)
+      real qs(len,nd)
+      real u(len,nd)
+      real v(len,nd)
+      real p(len,nd)
+      real ph(len,ndp1)
+      integer iflag(len)
+      real ft(len,nd)
+      real fq(len,nd)
+      real fu(len,nd)
+      real fv(len,nd)
+      real precip(len)
+      real cbmf(len)
+      real Ma(len,nd)
+      integer minorig
+      real delt,cpd,cpv,cl,rv,rd,lv0,g
+      real sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp
+      real alpha,entp,coeffs,coeffr,omtrain,cu
+c
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+      integer nl
+      integer nlp
+      integer nlm
+      integer i,k,n
+      real delti
+      real rowl
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real ginv
+      real hrd
+      real prccon1
+      integer icbmax
+      real lv(klon,klev)
+      real cpn(klon,klev)
+      real cpx(klon,klev)
+      real tv(klon,klev)
+      real gz(klon,klev)
+      real hm(klon,klev)
+      real h(klon,klev)
+      real work(klon)
+      integer ihmin(klon)
+      integer nk(klon)
+      real rh(klon)
+      real chi(klon)
+      real plcl(klon)
+      integer icb(klon)
+      real tnk(klon)
+      real qnk(klon)
+      real gznk(klon)
+      real pnk(klon)
+      real qsnk(klon)
+      real ticb(klon)
+      real gzicb(klon)
+      real tp(klon,klev)
+      real tvp(klon,klev)
+      real clw(klon,klev)
+c
+      real ah0(klon),cpp(klon)
+      real tg,qg,s,alv,tc,ahg,denom,es,rg
+c
+      integer ncum
+      integer idcum(klon)
+c
+      cpd=1005.7
+      cpv=1870.0
+      cl=4190.0
+      rv=461.5
+      rd=287.04
+      lv0=2.501E6
+      g=9.8
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+      sigs=0.12
+      sigd=0.05
+      elcrit=0.0011
+      tlcrit=-55.0
+      omtsnow=5.5
+      dtmax=0.9
+      damp=0.1
+      alpha=0.2
+      entp=1.5
+      coeffs=0.8
+      coeffr=1.0
+      omtrain=50.0
+c
+      cu=0.70
+      damp=0.1
+c
+c
+c Define nl, nlp, nlm, and delti
+c
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+      delti=1.0/delt
+!
+!-------------------------------------------------------------------
+! --- SET CONSTANTS
+!-------------------------------------------------------------------
+!
+      rowl=1000.0
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+      ginv=1.0/g
+      hrd=0.5*rd
+      prccon1=86400.0*1000.0/(rowl*g)
+!
+! dtmax is the maximum negative temperature perturbation.
+!
+!=====================================================================
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!=====================================================================
+!
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft(i,k)=0.0
+         fq(i,k)=0.0
+         fu(i,k)=0.0
+         fv(i,k)=0.0
+         tvp(i,k)=0.0
+         tp(i,k)=0.0
+         clw(i,k)=0.0
+         gz(i,k) = 0.
+ 10     continue
+ 20   continue
+      do 60 i=1,len
+        precip(i)=0.0
+        iflag(i)=0
+ 60   continue
+c
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+      do 110 k=1,nl+1
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+c
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+!
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+!
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+c
+      ncum=0
+      do 400 i=1,len
+        if(iflag(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+c
+c Call convect2, which compresses the points and computes the heating,
+c moistening, velocity mixing, and precipiation.
+c
+c     print*,'cpd avant convect2 ',cpd
+      if(ncum.gt.0)then
+      call convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &              nk,icb,
+     &              t,q,qs,u,v,gz,tv,tp,tvp,clw,h,
+     &              lv,cpn,p,ph,ft,fq,fu,fv,
+     &              tnk,qnk,gznk,plcl,
+     &              precip,cbmf,iflag,
+     &              delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &              sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &              alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+      endif
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/convect2.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/convect2.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/convect2.F	(revision 984)
@@ -0,0 +1,1395 @@
+!
+! $Header$
+!
+      subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &                 nk1,icb1,
+     &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+     &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+     &                 tnk1,qnk1,gznk1,plcl1,
+     &                 precip1,cbmf1,iflag1,
+     &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &                 alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect2.f	1.2 05/18/00
+C                       22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect2
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme - compute tendencies
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect2(ncum,idcum,len,nd,nl,minorig,
+C    &                 nk1,icb1,
+C    &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+C    &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+C    &                 tnk1,qnk1,gznk1,plcl1,
+C    &                 precip1,cbmf1,iflag1,
+C    &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+C    &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+C    &                 alpha,entp,coeffs,coeffr,omtrain,cu)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      ncum          Integer        Input        number of cumulus points
+C      idcum         Integer        Input        index of cumulus point
+C      len           Integer        Input        first dimension
+C      nd            Integer        Input        total vertical dimension
+C      ndp1          Integer        Input        nd + 1
+C      nl            Integer        Input        vertical dimension for convection
+C      minorig       Integer        Input        First level where convection is allow to begin
+C      nk1           Integer        Input        First level of convection
+C      ncb1          Integer        Input        Level of free convection
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      gz1           Real           Inout        geop
+C      tv1           Real           Input        virtual temp
+C      tp1           Real           Input
+C      clw1          Real           Inout        cloud liquid water
+C      h1            Real           Inout
+C      lv1           Real           Inout
+C      cpn1          Real           Inout
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      precip1       Real           Output       prec
+C      cbmf1         Real           In/Out       cumulus mass flux
+C      iflag1        Integer        Output       iflag on latitude strip
+C      delt          Real           Input        time step
+C      cpd           Integer        Input        See description below
+C      cpv           Integer        Input        See description below
+C      cl            Integer        Input        See description below
+C      rv            Integer        Input        See description below
+C      rd            Integer        Input        See description below
+C      lv0           Integer        Input        See description below
+C      g             Integer        Input        See description below
+C      sigs          Integer        Input        See description below
+C      sigd          Integer        Input        See description below
+C      elcrit        Integer        Input        See description below
+C      tlcrit        Integer        Input        See description below
+C      omtsnow       Integer        Input        See description below
+C      dtmax         Integer        Input        See description below
+C      damp          Integer        Input        See description below
+C      alpha         Integer        Input        See description below
+C      ent           Integer        Input        See description below
+C      coeffs        Integer        Input        See description below
+C      coeffr        Integer        Input        See description below
+C      omtrain       Integer        Input        See description below
+C      cu            Integer        Input        See description below
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         zilch        Zero out an array
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+      USE dimphy
+      implicit none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      integer kmax2,imax2,kmin2,imin2
+      real ftmax2,ftmin2
+      integer kmax,imax,kmin,imin
+      real ftmax,ftmin
+c
+      integer ncum
+      integer idcum(len)
+      integer len
+      integer nd
+      integer ndp1
+      integer nl
+      integer minorig
+      integer nk1(len)
+      integer icb1(len)
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real gz1(len,nd)
+      real tv1(len,nd)
+      real tp1(len,nd)
+      real tvp1(len,nd)
+      real clw1(len,nd)
+      real h1(len,nd)
+      real lv1(len,nd)
+      real cpn1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real tnk1(len)
+      real qnk1(len)
+      real gznk1(len)
+      real precip1(len)
+      real cbmf1(len)
+      real plcl1(len)
+      integer iflag1(len)
+      real delt
+      real cpd
+      real cpv
+      real cl
+      real rv
+      real rd
+      real lv0
+      real g
+      real sigs    ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE
+      real sigd    ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT
+      real elcrit  ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm)
+      real tlcrit  ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-
+c                     CONVERSION THRESHOLD IS ASSUMED TO BE ZERO
+      real omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW
+      real dtmax   ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
+c                    A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC.
+      real damp
+      real alpha
+      real entp    ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION
+      real coeffs  ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF SNOW
+      real coeffr  ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF RAIN
+      real omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN
+      real cu      ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT
+c
+      real Ma(len,nd)
+c
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+c Local arrays.
+c
+      real work(ncum)
+      real t(ncum,klev)
+      real q(ncum,klev)
+      real qs(ncum,klev)
+      real u(ncum,klev)
+      real v(ncum,klev)
+      real gz(ncum,klev)
+      real h(ncum,klev)
+      real lv(ncum,klev)
+      real cpn(ncum,klev)
+      real p(ncum,klev)
+      real ph(ncum,klev)
+      real ft(ncum,klev)
+      real fq(ncum,klev)
+      real fu(ncum,klev)
+      real fv(ncum,klev)
+      real precip(ncum)
+      real cbmf(ncum)
+      real plcl(ncum)
+      real tnk(ncum)
+      real qnk(ncum)
+      real gznk(ncum)
+      real tv(ncum,klev)
+      real tp(ncum,klev)
+      real tvp(ncum,klev)
+      real clw(ncum,klev)
+c     real det(ncum,klev)
+      real dph(ncum,klev)
+c     real wd(ncum)
+c     real tprime(ncum)
+c     real qprime(ncum)
+      real ah0(ncum)
+      real ep(ncum,klev)
+      real sigp(ncum,klev)
+      integer nent(ncum,klev)
+      real water(ncum,klev)
+      real evap(ncum,klev)
+      real mp(ncum,klev)
+      real m(ncum,klev)
+      real qti
+      real wt(ncum,klev)
+      real hp(ncum,klev)
+      real lvcp(ncum,klev)
+      real elij(ncum,klev,klev)
+      real ment(ncum,klev,klev)
+      real sij(ncum,klev,klev)
+      real qent(ncum,klev,klev)
+      real uent(ncum,klev,klev)
+      real vent(ncum,klev,klev)
+      real qp(ncum,klev)
+      real up(ncum,klev)
+      real vp(ncum,klev)
+      real cape(ncum)
+      real capem(ncum)
+      real frac(ncum)
+      real dtpbl(ncum)
+      real tvpplcl(ncum)
+      real tvaplcl(ncum)
+      real dtmin(ncum)
+      real w3d(ncum,klev)
+      real am(ncum)
+      real ents(ncum)
+      real uav(ncum)
+      real vav(ncum)
+c
+      integer iflag(ncum)
+      integer nk(ncum)
+      integer icb(ncum)
+      integer inb(ncum)
+      integer inb1(ncum)
+      integer jtt(ncum)
+c
+      integer nn,i,k,n,icbmax,nlp,j
+      integer ij
+      integer nn2,nn3
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real tg,qg,s,alv,tc,ahg,denom,es,rg,ginv,rowl
+      real delti
+      real tca,elacrit
+      real by,defrac
+c     real byp
+      real byp(ncum)
+      logical lcape(ncum)
+      real dbo
+      real bf2,anum,dei,altem,cwat,stemp
+      real alt,qp1,smid,sjmax,sjmin
+      real delp,delm
+      real awat,coeff,afac,revap,dhdp,fac,qstm,rat
+      real qsm,sigt,b6,c6
+      real dpinv,cpinv
+      real fqold,ftold,fuold,fvold
+      real wdtrain(ncum),xxx
+      real bsum(ncum,klev)
+      real asij(ncum)
+      real smin(ncum)
+      real scrit(ncum)
+c     real amp1,ad
+      real amp1(ncum),ad(ncum)
+      logical lwork(ncum)
+      integer num1,num2
+c
+c     print*,'cpd en entree de convect2 ',cpd
+      nlp=nl+1
+c
+      rowl=1000.0
+      ginv=1.0/g
+      delti=1.0/delt
+c
+c Define some thermodynamic variables.
+c
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c
+c Compress the fields.
+c
+      do 110 k=1,nl+1
+       nn=0
+	do 100 i=1,len
+	  if(iflag1(i).eq.0)then
+	    nn=nn+1
+	    t(nn,k)=t1(i,k)
+	    q(nn,k)=q1(i,k)
+	    qs(nn,k)=qs1(i,k)
+	    u(nn,k)=u1(i,k)
+	    v(nn,k)=v1(i,k)
+	    gz(nn,k)=gz1(i,k)
+	    h(nn,k)=h1(i,k)
+	    lv(nn,k)=lv1(i,k)
+	    cpn(nn,k)=cpn1(i,k)
+	    p(nn,k)=p1(i,k)
+	    ph(nn,k)=ph1(i,k)
+	    tv(nn,k)=tv1(i,k)
+	    tp(nn,k)=tp1(i,k)
+	    tvp(nn,k)=tvp1(i,k)
+	    clw(nn,k)=clw1(i,k)
+	  endif
+ 100    continue
+c       print*,'100 ncum,nn',ncum,nn
+ 110  continue
+      nn=0
+      do 150 i=1,len
+	if(iflag1(i).eq.0)then
+	  nn=nn+1
+	  cbmf(nn)=cbmf1(i)
+	  plcl(nn)=plcl1(i)
+	  tnk(nn)=tnk1(i)
+	  qnk(nn)=qnk1(i)
+	  gznk(nn)=gznk1(i)
+	  nk(nn)=nk1(i)
+	  icb(nn)=icb1(i)
+	  iflag(nn)=iflag1(i)
+	endif
+ 150  continue
+c       print*,'150 ncum,nn',ncum,nn
+c
+c Initialize the tendencies, det, wd, tprime, qprime.
+c
+      do 170 k=1,nl
+	do 160 i=1,ncum
+c         det(i,k)=0.0
+	  ft(i,k)=0.0
+	  fu(i,k)=0.0
+	  fv(i,k)=0.0
+	  fq(i,k)=0.0
+	  dph(i,k)=ph(i,k)-ph(i,k+1)
+	  ep(i,k)=0.0
+	  sigp(i,k)=sigs
+ 160    continue
+ 170  continue
+      do 180 i=1,ncum
+c      wd(i)=0.0
+c      tprime(i)=0.0
+c      qprime(i)=0.0
+       precip(i)=0.0
+       ft(i,nl+1)=0.0
+       fu(i,nl+1)=0.0
+       fv(i,nl+1)=0.0
+       fq(i,nl+1)=0.0
+ 180  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 230 i=1,ncum
+	icbmax=max(icbmax,icb(i))
+ 230  continue
+c
+c
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+	ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+	       tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)
+     &                  /cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-273.15
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c
+c=====================================================================
+c --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          water(i,1)=0.0
+          evap(i,1)=0.0
+          mp(i,1)=0.0
+          m(i,1)=0.0
+          wt(i,1)=omtsnow
+          hp(i,1)=h(i,1)
+c         if(.not.cpn(i,1).gt.900.) then
+c         print*,'i,lv(i,1),cpn(i,1)'
+c         print*, i,lv(i,1),cpn(i,1)
+c         k=(i-1)/ncum+1
+c         print*,'i,k',mod(i,ncum),k,'  cpn',cpn(mod(i,ncum),k)
+c         stop
+c         endif
+          lvcp(i,1)=lv(i,1)/cpn(i,1)
+ 360    continue
+c
+      do 380 i=1,ncum*nlp*nlp
+        elij(i,1,1)=0.0
+        ment(i,1,1)=0.0
+        sij(i,1,1)=0.0
+ 380  continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+ 385      continue
+ 390    continue
+ 400  continue
+c
+      do 420 i=1,ncum
+        qp(i,1)=q(i,1)
+        up(i,1)=u(i,1)
+        vp(i,1)=v(i,1)
+ 420  continue
+      do 440 k=2,nlp
+        do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430    continue
+ 440  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),
+c --- AT EACH MODEL LEVEL
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+c
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+c     wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
+c     qprime=0.5*(qp(1)-q(1))
+c     tprime=lv0*qprime/cpd
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+           endif
+ 1910    continue
+ 1920   continue
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+ 2010     continue
+ 2020   continue
+c
+      DO k=1,nd
+        DO i=1,len
+         Ma(i,k) = 0.
+        ENDDO
+      ENDDO
+      DO k=nl,1,-1
+        DO i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        ENDDO
+      ENDDO
+c
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/convect3.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/convect3.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/convect3.F	(revision 984)
@@ -0,0 +1,1408 @@
+!
+! $Header$
+!
+      SUBROUTINE CONVECT3	
+     *    (DTIME,EPMAX,ok_adj,
+     *     T1,   R1,   RS,    U,  V,  TRA,   P,     PH,
+     *     ND,       NDP1,     NL, NTRA,  DELT,  IFLAG,
+     *     FT, FR, FU,  FV,  FTRA,  PRECIP,
+     *     icb,inb,   upwd,dnwd,dnwd0,SIG, W0,Mike,Mke,
+     *     Ma,MENTS,QENTS,TPS,TLS,SIGIJ,CAPE,TVP,PBASE,BUOYBASE,
+cccc     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
+     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR,   ! sbl
+     *     FT2,FR2,FU2,FV2,WD,QCOND,QCONDC)   ! sbl
+C
+C    ***  THE PARAMETER NA SHOULD IN GENERAL EQUAL ND   ***
+C
+c#################################################################
+cFleur       Introduction des traceurs dans convect3 le 6 juin 200
+c#################################################################
+      USE dimphy
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+      PARAMETER (NA=60)
+
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+      REAL DELTAC              ! cld
+      PARAMETER (DELTAC=0.01)  ! cld
+
+      INTEGER NENT(NA)
+      REAL T1(ND),R1(ND),RS(ND),U(ND),V(ND),TRA(ND,NTRA)
+      REAL P(ND),PH(NDP1)
+      REAL FT(ND),FR(ND),FU(ND),FV(ND),FTRA(ND,NTRA)
+      REAL SIG(ND),W0(ND)
+      REAL UENT(NA,NA),VENT(NA,NA),TRAENT(NA,NA,NTRAC),TRATM(NA)
+      REAL UP(NA),VP(NA),TRAP(NA,NTRAC)
+      REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
+      REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
+      REAL RP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
+      REAL SIGP(NA),B(NA),TP(NA),CPN(NA)
+      REAL LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA)
+      REAL T(NA),RR(NA)
+C
+      REAL FT2(ND),FR2(ND),FU2(ND),FV2(ND) ! added sbl
+      REAL U1(ND),V1(ND) ! added sbl
+C
+      REAL BUOY(NA)     !  Lifted parcel buoyancy
+      REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                      temperature wrt T1 and Q1
+      REAL CLW_NEW(NA),QI(NA)
+C
+      REAL WD, BETAD ! for gust factor (sb)
+      REAL QCONDC(ND)  ! interface cld param (sb)
+      REAL QCOND(ND),NQCOND(NA),WA(NA),MAA(NA),SIGA(NA),AXC(NA) ! cld
+C
+      LOGICAL ICE_CONV,ok_adj
+      PARAMETER (ICE_CONV=.TRUE.)
+ 
+cccccccccccccccccccccccccccccccccccccccccccccc
+c     declaration des variables a sortir
+ccccccccccccccccccccccccccccccccccccccccccccc
+      real Mke(nd)
+      real Mike(nd)
+      real Ma(nd)
+      real TPS(ND) !temperature dans les ascendances non diluees
+      real TLS(ND) !temperature potentielle
+      real MENTS(nd,nd)
+      real QENTS(nd,nd)
+      REAL SIGIJ(KLEV,KLEV)
+      REAL PBASE ! pressure at the cloud base level
+      REAL BUOYBASE ! buoyancy at the cloud base level
+cccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+ 
+c
+      real dnwd0(nd)  !  precipitation driven unsaturated downdraft flux
+      real dnwd(nd), dn1  ! in-cloud saturated downdraft mass flux
+      real upwd(nd), up1  ! in-cloud saturated updraft mass flux
+C
+C   ***         ASSIGN VALUES OF THERMODYNAMIC CONSTANTS        ***
+C   ***             THESE SHOULD BE CONSISTENT WITH             ***
+C   ***              THOSE USED IN CALLING PROGRAM              ***
+C   ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
+C
+c sb      CPD=1005.7
+c sb      CPV=1870.0
+c sb      CL=4190.0
+c sb      CPVMCL=CL-CPV
+c sb      RV=461.5
+c sb      RD=287.04
+c sb      EPS=RD/RV
+c sb      ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CPVMCL=CL-CPV
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+cccccccccccccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+       NK = 1 ! origin level of the lifted parcel
+c
+cccccccccccccccccccccc
+C
+C           ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
+C
+      DO 5 I=1,ND
+         FT(I)=0.0
+         FR(I)=0.0
+         FU(I)=0.0
+         FV(I)=0.0
+
+         FT2(I)=0.0
+         FR2(I)=0.0
+         FU2(I)=0.0
+         FV2(I)=0.0
+
+         DO 4 J=1,NTRA
+          FTRA(I,J)=0.0
+    4    CONTINUE
+
+         QCONDC(I)=0.0  ! cld
+         QCOND(I)=0.0   ! cld
+         NQCOND(I)=0.0  ! cld
+
+         T(I)=T1(I)
+         RR(I)=R1(I)
+         U1(I)=U(I) ! added sbl
+         V1(I)=V(I) ! added sbl
+    5 CONTINUE
+      DO 7 I=1,NL
+         RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+         TH(I)=T(I)*(1000.0/P(I))**RDCP
+    7 CONTINUE
+C
+*************************************************************
+**    CALCUL DES TEMPERATURES POTENTIELLES A SORTIR
+*************************************************************
+      do i=1,ND
+      RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+ 
+      TLS(i)=T(I)*(1000.0/P(I))**RDCP
+      enddo
+ 
+ 
+ 
+ 
+************************************************************
+ 
+ 
+      PRECIP=0.0
+      WD=0.0 ! sb
+      IFLAG=1
+C
+C   ***                    SPECIFY PARAMETERS                        ***
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE   ***
+C   ***       PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO         ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP.      ***
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY                 ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE      ***
+C   ***                        OF CLOUD                              ***
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY)    ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)             ***
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***                     IT MUST BE LESS THAN 0                   ***
+C
+      PBCRIT=150.0
+      PTCRIT=500.0
+      SIGD=0.01
+      SPFAC=0.15
+c sb:
+c     EPMAX=0.993 ! precip efficiency less than unity
+c      EPMAX=1. ! precip efficiency less than unity
+C
+Cjyg
+CCC      BETA=0.96
+C  Beta is now expressed as a function of the characteristic time
+C  of the convective process.
+CCC        Old value : TAU = 15000.   !(for dtime = 600.s)
+CCC        Other value (inducing little change) :TAU = 8000.
+      TAU = 8000.
+      BETA = 1.-DTIME/TAU
+Cjyg
+CCC      ALPHA=1.0
+      ALPHA=1.5E-3*DTIME/TAU
+C        Increase alpha in order to compensate W decrease
+      ALPHA = ALPHA*1.5
+C
+Cjyg (voir CONVECT 3)
+CCC      DTCRIT=-0.2
+      DTCRIT=-2.
+Cgf&jyg
+CCC     DT pour l'overshoot.
+      DTOVSH = -0.2
+ 
+C
+C           ***        INCREMENT THE COUNTER       ***
+C
+      SIG(ND)=SIG(ND)+1.0
+      SIG(ND)=AMIN1(SIG(ND),12.1)
+C
+C           ***    IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT     ***
+C           ***     RETURNS ARRAYS T AND R THAT MAY HAVE BEEN      ***
+C           ***  ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE    ***
+C           ***        THE RETURNED ARRAYS ARE UNALTERED.          ***
+C
+      NOPT=0
+c!      NOPT=1 ! sbl
+C
+C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
+C
+C     ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
+C     ***                BOUNDARY LAYER SCHEME !!!               ***
+C
+      IF (ok_adj) THEN ! added sbl
+
+      DO 30 I=NL-1,1,-1
+         JN=0
+         DO 10 J=I+1,NL
+   10    IF(TH(J).LT.TH(I))JN=J
+         IF(JN.EQ.0)GOTO 30
+         AHM=0.0
+         RM=0.0
+         UM=0.0
+         VM=0.0
+         DO K=1,NTRA
+          TRATM(K)=0.0
+         END DO
+         DO 15 J=I,JN
+          AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1))
+          RM=RM+RR(J)*(PH(J)-PH(J+1))
+          UM=UM+U(J)*(PH(J)-PH(J+1))
+          VM=VM+V(J)*(PH(J)-PH(J+1))
+          DO K=1,NTRA
+           TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1))
+          END DO
+   15    CONTINUE
+         DPHINV=1./(PH(I)-PH(JN+1))
+         RM=RM*DPHINV
+         UM=UM*DPHINV
+         VM=VM*DPHINV
+         DO K=1,NTRA
+          TRATM(K)=TRATM(K)*DPHINV
+         END DO
+         A2=0.0
+         DO 20 J=I,JN
+            RR(J)=RM
+          U(J)=UM
+          V(J)=VM
+          DO K=1,NTRA
+           TRA(J,K)=TRATM(K)
+          END DO
+            RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV)
+            X=(0.001*P(J))**RDCP
+            T(J)=X
+            A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1))
+   20    CONTINUE
+         DO 25 J=I,JN
+            TH(J)=AHM/A2
+            T(J)=T(J)*TH(J)
+   25    CONTINUE
+   30 CONTINUE
+
+      ENDIF ! added sbl
+C
+C   ***   RESET INPUT ARRAYS IF ok_adj 0   ***
+C
+      IF (ok_adj)THEN
+         DO 35 I=1,ND
+
+           FT2(I)=(T(I)-T1(I))/DELT  ! sbl
+           FR2(I)=(RR(I)-R1(I))/DELT  ! sbl
+           FU2(I)=(U(I)-U1(I))/DELT  ! sbl
+           FV2(I)=(V(I)-V1(I))/DELT  ! sbl
+
+c!            T1(I)=T(I)      ! commente sbl
+c!            R1(I)=RR(I)     ! commente sbl
+   35    CONTINUE
+      END IF
+C
+C  *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+C
+      GZ(1)=0.0
+      CPN(1)=CPD*(1.-RR(1))+RR(1)*CPV
+      H(1)=T(1)*CPN(1)
+      DO 40 I=2,NL
+        TVX=T(I)*(1.+RR(I)/EPS-RR(I))
+        TVY=T(I-1)*(1.+RR(I-1)/EPS-RR(I-1))
+        GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I)
+        CPN(I)=CPD*(1.-RR(I))+CPV*RR(I)
+        H(I)=T(I)*CPN(I)+GZ(I)
+   40 CONTINUE
+C
+C   ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL ***
+C   ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)     ***
+C
+      IF (T(1).LT.250.0.OR.RR(1).LE.0.0)THEN
+         IFLAG=0
+c sb3d         print*,'je suis passe par 366'
+         RETURN
+      END IF
+
+cjyg1 Utilisation de la subroutine CLIFT
+CC      RH=RR(1)/RS(1)
+CC      CHI=T(1)/(1669.0-122.0*RH-T(1))
+CC      PLCL=P(1)*(RH**CHI)
+      CALL CLIFT(P(1),T(1),RR(1),RS(1),PLCL,DPLCLDT,DPLCLDR)
+cjyg2
+c sb3d      PRINT *,' em_plcl,p1,t1,r1,rs1,rh '
+c sb3d     $        ,PLCL,P(1),T(1),RR(1),RS(1),RH
+c
+      IF (PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+         IFLAG=2
+         RETURN
+      END IF
+Cjyg1
+C     Essais de modification de ICB
+C
+C   ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
+C
+CC      ICB=NL-1
+CC      DO 50 I=2,NL-1
+CC         IF(P(I).LT.PLCL)THEN
+CC            ICB=MIN(ICB,I)   ! ICB sup ou egal a 2
+CC         END IF
+CC   50 CONTINUE
+CC      IF(ICB.EQ.(NL-1))THEN
+CC         IFLAG=3
+CC         RETURN
+CC      END IF
+C
+C   *** CALCULATE LAYER CONTAINING LCL (=ICB)   ***
+C
+      ICB=NL-1
+c sb      DO 50 I=2,NL-1
+      DO 50 I=3,NL-1 ! modif sb pour que ICB soit sup/egal a 2
+C   la modification consiste a comparer PLCL a PH et non a P:
+C   ICB est defini par :  PH(ICB)<PLCL<PH(ICB-!)
+         IF(PH(I).LT.PLCL)THEN
+            ICB=MIN(ICB,I)
+         END IF
+   50 CONTINUE
+      IF(ICB.EQ.(NL-1))THEN
+         IFLAG=3
+         RETURN
+      END IF
+      ICB = ICB-1 ! ICB sup ou egal a 2 
+Cjyg2
+C
+C
+ 
+C   *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL      ***
+C   ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC             ***
+C   ***                   LIQUID WATER CONTENT                             ***
+C
+ 
+cjyg1
+c make sure that "Cloud base" seen by TLIFT is actually the 
+c fisrt level where adiabatic ascent is saturated 
+       IF (PLCL .GT. P(ICB)) THEN
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ELSE
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ENDIF
+cjyg2
+ 
+******************************************************************************
+****     SORTIE DE LA TEMPERATURE DE L ASCENDANCE NON DILUE
+******************************************************************************
+        do i=1,ND
+        TPS(i)=TP(i)
+        enddo
+ 
+ 
+******************************************************************************
+ 
+C
+C   ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
+C   ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
+C   ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
+C
+      DO 55 I=1,NL
+         PDEN=PTCRIT-PBCRIT
+c
+cjyg
+ccc         EP(I)=(P(ICB)-P(I)-PBCRIT)/PDEN
+c sb         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN
+         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN * EPMAX ! sb
+c
+         EP(I)=AMAX1(EP(I),0.0)
+c sb         EP(I)=AMIN1(EP(I),1.0)
+         EP(I)=AMIN1(EP(I),EPMAX) ! sb
+         SIGP(I)=SPFAC
+C
+C   ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
+C   ***                    VIRTUAL TEMPERATURE                    ***
+C
+         TV(I)=T(I)*(1.+RR(I)/EPS-RR(I))
+Ccd1
+C    . Keep all liquid water in lifted parcel (-> adiabatic CAPE)
+C
+ccc    TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I))
+c!!! sb         TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift
+Ccd2
+C
+C   ***       Calculate first estimate of buoyancy
+C
+         BUOY(I) = TVP(I) - TV(I)
+   55 CONTINUE
+C
+C   ***   Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy
+C
+      DPBASE = -40.   !That is 400m above LCL
+      PBASE = PLCL + DPBASE
+      TVPBASE = TVP(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $         +TVP(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+      TVBASE = TV(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $        +TV(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+C
+c test sb:
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c@      write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1)
+c@     :             ,tv(icb),tv(icb1)'
+c@      write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb)
+c@     L          ,tvp(icb+1),tv(icb),tv(icb+1)
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c fin test sb
+      BUOYBASE = TVPBASE - TVBASE
+C
+CC       Set buoyancy = BUOYBASE for all levels below BASE.
+CC       For safety, set : BUOY(ICB) = BUOYBASE
+      DO I = ICB,NL
+        IF (P(I) .GE. PBASE) THEN
+          BUOY(I) = BUOYBASE
+        ENDIF
+      ENDDO
+      BUOY(ICB) = BUOYBASE
+C
+c sb3d      print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl'
+c sb3d     $,        buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl
+c sb3d      print *,'TVP ',(tvp(i),i=1,nl)
+c sb3d      print *,'TV ',(tv(i),i=1,nl)
+c sb3d      print *, 'P ',(p(i),i=1,nl)
+c sb3d      print *,'ICB ',icb
+c test sb:
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c@      write(*,*) 'icb,icbs,inb,buoybase:'
+c@      write(*,*) icb,icb+1,inb,buoybase
+c@      write(*,*) 'k,tvp,tv,tp,buoy,ep: '
+c@      do k=1,nl
+c@      write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k)
+c@      enddo
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c fin test sb
+
+
+C
+C   ***   MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE  ***
+C   ***    AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT  ***
+C   ***                         AT CLOUD BASE                         ***
+C   ***       IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING       ***
+C   ***                        SIG(I) AND W0(I)                       ***
+C
+Cjyg
+CCC      TDIF=TVP(ICB)-TV(ICB)
+      TDIF = BUOY(ICB)
+      ATH1=TH(1)
+Cjyg
+CCC      ATH=TH(ICB-1)-1.0
+      ATH=TH(ICB-1)-5.0
+c      ATH=0.                          ! ajout sb
+c      IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb
+      IF(TDIF.LT.DTCRIT.OR.ATH.GT.ATH1)THEN
+         DO 60 I=1,NL
+            SIG(I)=BETA*SIG(I)-2.*ALPHA*TDIF*TDIF
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   60    CONTINUE
+         IFLAG=0
+         RETURN
+      END IF
+C
+ 
+ 
+C   ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
+C   ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS       ***
+C
+      DO 70 I=1,NL
+         HP(I)=H(I)
+         WT(I)=0.001
+         RP(I)=RR(I)
+         UP(I)=U(I)
+         VP(I)=V(I)
+         DO 71 J=1,NTRA
+          TRAP(I,J)=TRA(I,J)
+   71    CONTINUE
+         NENT(I)=0
+         WATER(I)=0.0
+         EVAP(I)=0.0
+         B(I)=0.0
+         MP(I)=0.0
+         M(I)=0.0
+         LV(I)=ALV0-CPVMCL*(T(I)-273.15)
+         LVCP(I)=LV(I)/CPN(I)
+         DO 70 J=1,NL
+            QENT(I,J)=RR(J)
+            ELIJ(I,J)=0.0
+            MENT(I,J)=0.0
+            SIJ(I,J)=0.0
+          UENT(I,J)=U(J)
+          VENT(I,J)=V(J)
+          DO 70 K=1,NTRA
+           TRAENT(I,J,K)=TRA(J,K)
+   70 CONTINUE
+ 
+      DELTI=1.0/DELT
+C
+C  ***  FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S       ***
+C  ***                LEVEL OF NEUTRAL BUOYANCY                   ***
+C
+      INB=NL-1
+      DO 80 I=ICB,NL-1
+Cjyg
+CCC         IF((TVP(I)-TV(I)).LT.DTCRIT)THEN
+         IF(BUOY(I).LT.DTOVSH)THEN
+            INB=MIN(INB,I)
+         END IF
+   80 CONTINUE
+ 
+ 
+ 
+ 
+C
+C   ***          RESET SIG(I) AND W0(I) FOR I>INB AND I<ICB       ***
+C
+      IF(INB.LT.(NL-1))THEN
+         DO 85 I=INB+1,NL-1
+Cjyg
+CCC            SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(INB)-TVP(INB))*
+CCC     1              ABS(TV(INB)-TVP(INB))
+            SIG(I)=BETA*SIG(I)+2.*ALPHA*BUOY(INB)*
+     1              ABS(BUOY(INB))
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   85    CONTINUE
+      END IF
+      DO 87 I=1,ICB
+Cjyg
+CCC         SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(ICB)-TVP(ICB))*
+CCC     1           (TV(ICB)-TVP(ICB))
+         SIG(I)=BETA*SIG(I)-2.*ALPHA*BUOY(ICB)*BUOY(ICB)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         W0(I)=BETA*W0(I)
+   87 CONTINUE
+C
+C   ***    RESET FRACTIONAL AREAS OF UPDRAFTS AND W0 AT INITIAL TIME    ***
+C   ***           AND AFTER 10 TIME STEPS OF NO CONVECTION              ***
+C
+ 
+      IF(SIG(ND).LT.1.5.OR.SIG(ND).GT.12.0)THEN
+         DO 90 I=1,NL-1
+            SIG(I)=0.0
+            W0(I)=0.0
+   90    CONTINUE
+      END IF
+C
+C   ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
+C
+      DO 95 I=ICB,INB
+         HP(I)=H(1)+(LV(I)+(CPD-CPV)*T(I))*EP(I)*CLW(I)
+   95 CONTINUE
+C
+C   ***  CALCULATE CONVECTIVE AVAILABLE POTENTIAL ENERGY (CAPE),  ***
+C   ***     VERTICAL VELOCITY (W), FRACTIONAL AREA COVERED BY     ***
+C   ***     UNDILUTE UPDRAFT (SIG),  AND UPDRAFT MASS FLUX (M)    ***
+C
+      CAPE=0.0
+C
+      DO 98 I=ICB+1,INB
+Cjyg1
+CCC         CAPE=CAPE+RD*(TVP(I-1)-TV(I-1))*(PH(I-1)-PH(I))/P(I-1)
+CCC         DCAPE=RD*BUOY(I-1)*(PH(I-1)-PH(I))/P(I-1)
+CCC         DLNP=(PH(I-1)-PH(I))/P(I-1)
+C          The interval on which CAPE is computed starts at PBASE :
+         DELTAP = MIN(PBASE,PH(I-1))-MIN(PBASE,PH(I))
+         CAPE=CAPE+RD*BUOY(I-1)*DELTAP/P(I-1)
+         DCAPE=RD*BUOY(I-1)*DELTAP/P(I-1)
+         DLNP=DELTAP/P(I-1)
+Cjyg2
+c sb3d         print *,'buoy,dlnp,dcape,cape',buoy(i-1),dlnp,dcape,cape
+c test sb:
+c@       write(*,*) '############################################'
+c@         write(*,*) 'cape,rrd,buoy,deltap,p,pbase,ph:'
+c@     :     ,cape,rd,buoy(i-1),deltap,p(i-1),pbase,ph(i)
+c@       write(*,*) '############################################'
+
+c fin test sb
+         CAPE=AMAX1(0.0,CAPE)
+C
+         SIGOLD=SIG(I)
+         DTMIN=100.0
+         DO 97 J=ICB,I-1
+Cjyg
+CCC            DTMIN=AMIN1(DTMIN,(TVP(J)-TV(J)))
+            DTMIN=AMIN1(DTMIN,BUOY(J))
+   97    CONTINUE
+c sb3d     print *, 'DTMIN, BETA, ALPHA, SIG = ',DTMIN,BETA,ALPHA,SIG(I)
+         SIG(I)=BETA*SIG(I)+ALPHA*DTMIN*ABS(DTMIN)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         SIG(I)=AMIN1(SIG(I),0.01)
+         FAC=AMIN1(((DTCRIT-DTMIN)/DTCRIT),1.0)
+Cjyg
+CC    Essais de reduction de la vitesse
+CC         FAC = FAC*.5
+C
+         W=(1.-BETA)*FAC*SQRT(CAPE)+BETA*W0(I)
+         AMU=0.5*(SIG(I)+SIGOLD)*W
+         M(I)=AMU*0.007*P(I)*(PH(I)-PH(I+1))/TV(I)
+
+c --------- test sb:
+c       write(*,*) '############################################'
+c       write(*,*) 'k,amu,buoy(k-1),deltap,w,beta,fac,cape,w0(k)'
+c       write(*,*) i,amu,buoy(i-1),deltap
+c     :           ,w,beta,fac,cape,w0(i)
+c       write(*,*) '############################################'
+c ---------
+
+         W0(I)=W
+   98 CONTINUE
+      W0(ICB)=0.5*W0(ICB+1)
+      M(ICB)=0.5*M(ICB+1)*(PH(ICB)-PH(ICB+1))/(PH(ICB+1)-PH(ICB+2))
+      SIG(ICB)=SIG(ICB+1)
+      SIG(ICB-1)=SIG(ICB)
+cjyg1
+c sb3d      print *, 'Cloud base, c. top, CAPE',ICB,INB,cape
+c sb3d      print *, 'SIG ',(sig(i),i=1,inb)
+c sb3d      print *, 'W ',(w0(i),i=1,inb)
+c sb3d      print *, 'M ',(m(i), i=1,inb)
+c sb3d      print *, 'Dt1 ',(tvp(i)-tv(i),i=1,inb)
+c sb3d      print *, 'Dt_vrai ',(buoy(i),i=1,inb)
+Cjyg2
+C
+C   ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
+C   ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
+C   ***                        FRACTION (SIJ)                          ***
+C
+ 
+ 
+      DO 170 I=ICB,INB
+         RTI=RR(1)-EP(I)*CLW(I)
+         DO 160 J=ICB-1,INB
+            BF2=1.+LV(J)*LV(J)*RS(J)/(RV*T(J)*T(J)*CPD)
+            ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(RTI-RR(J))
+            DENOM=H(I)-HP(I)+(CPD-CPV)*(RR(I)-RTI)*T(J)
+            DEI=DENOM
+            IF(ABS(DEI).LT.0.01)DEI=0.01
+            SIJ(I,J)=ANUM/DEI
+            SIJ(I,I)=1.0
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM/BF2
+            CWAT=CLW(J)*(1.-EP(J))
+            STEMP=SIJ(I,J)
+            IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR.
+     1      ALTEM.GT.CWAT).AND.J.GT.I)THEN
+            ANUM=ANUM-LV(J)*(RTI-RS(J)-CWAT*BF2)
+            DENOM=DENOM+LV(J)*(RR(I)-RTI)
+            IF(ABS(DENOM).LT.0.01)DENOM=0.01
+            SIJ(I,J)=ANUM/DENOM
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM-(BF2-1.)*CWAT
+            END IF
+ 
+ 
+            IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.95)THEN
+               QENT(I,J)=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI
+               UENT(I,J)=SIJ(I,J)*U(I)+(1.-SIJ(I,J))*U(NK)
+               VENT(I,J)=SIJ(I,J)*V(I)+(1.-SIJ(I,J))*V(NK)
+               DO K=1,NTRA
+               TRAENT(I,J,K)=SIJ(I,J)*TRA(I,K)+(1.-SIJ(I,J))*
+     1         TRA(NK,K)
+               END DO
+               ELIJ(I,J)=ALTEM
+               ELIJ(I,J)=AMAX1(0.0,ELIJ(I,J))
+               MENT(I,J)=M(I)/(1.-SIJ(I,J))
+               NENT(I)=NENT(I)+1
+            END IF
+            SIJ(I,J)=AMAX1(0.0,SIJ(I,J))
+            SIJ(I,J)=AMIN1(1.0,SIJ(I,J))
+  160    CONTINUE
+C
+C   ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS  ***
+C   ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES  ***
+C
+         IF(NENT(I).EQ.0)THEN
+            MENT(I,I)=M(I)
+            QENT(I,I)=RR(NK)-EP(I)*CLW(I)
+           UENT(I,I)=U(NK)
+           VENT(I,I)=V(NK)
+           DO J=1,NTRA
+            TRAENT(I,I,J)=TRA(NK,J)
+           END DO
+            ELIJ(I,I)=CLW(I)
+            SIJ(I,I)=1.0
+         END IF
+C
+         DO J = ICB-1,INB
+           SIGIJ(I,J) = SIJ(I,J)
+         ENDDO
+C	
+  170 CONTINUE
+C
+C   ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
+C   ***              PROBABILITIES OF MIXING                     ***
+C
+ 
+      DO 200 I=ICB,INB
+      IF(NENT(I).NE.0)THEN
+       QP=RR(1)-EP(I)*CLW(I)
+       ANUM=H(I)-HP(I)-LV(I)*(QP-RS(I))+(CPV-CPD)*T(I)*
+     1    (QP-RR(I))
+       DENOM=H(I)-HP(I)+LV(I)*(RR(I)-QP)+
+     1    (CPD-CPV)*T(I)*(RR(I)-QP)
+       IF(ABS(DENOM).LT.0.01)DENOM=0.01
+       SCRIT=ANUM/DENOM
+       ALT=QP-RS(I)+SCRIT*(RR(I)-QP)
+       IF(SCRIT.LE.0.0.OR.ALT.LE.0.0)SCRIT=1.0
+       SMAX=0.0
+       ASIJ=0.0
+        DO 175 J=INB,ICB-1,-1
+        IF(SIJ(I,J).GT.1.0E-16.AND.SIJ(I,J).LT.0.95)THEN
+         WGH=1.0
+         IF(J.GT.I)THEN
+          SJMAX=AMAX1(SIJ(I,J+1),SMAX)
+          SJMAX=AMIN1(SJMAX,SCRIT)
+          SMAX=AMAX1(SIJ(I,J),SMAX)
+          SJMIN=AMAX1(SIJ(I,J-1),SMAX)
+          SJMIN=AMIN1(SJMIN,SCRIT)
+          IF(SIJ(I,J).LT.(SMAX-1.0E-16))WGH=0.0
+          SMID=AMIN1(SIJ(I,J),SCRIT)
+         ELSE
+          SJMAX=AMAX1(SIJ(I,J+1),SCRIT)
+          SMID=AMAX1(SIJ(I,J),SCRIT)
+          SJMIN=0.0
+          IF(J.GT.1)SJMIN=SIJ(I,J-1)
+          SJMIN=AMAX1(SJMIN,SCRIT)
+         END IF
+         DELP=ABS(SJMAX-SMID)
+         DELM=ABS(SJMIN-SMID)
+         ASIJ=ASIJ+WGH*(DELP+DELM)
+         MENT(I,J)=MENT(I,J)*(DELP+DELM)*WGH
+        END IF
+  175       CONTINUE
+       ASIJ=AMAX1(1.0E-16,ASIJ)
+       ASIJ=1.0/ASIJ
+       DO 180 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASIJ
+  180    CONTINUE
+       ASUM=0.0
+       BSUM=0.0
+       DO 190 J=ICB-1,INB
+        ASUM=ASUM+MENT(I,J)
+        MENT(I,J)=MENT(I,J)*SIG(J)
+        BSUM=BSUM+MENT(I,J)
+  190       CONTINUE
+       BSUM=AMAX1(BSUM,1.0E-16)
+       BSUM=1.0/BSUM
+       DO 195 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASUM*BSUM	
+  195       CONTINUE
+       CSUM=0.0
+       DO 197 J=ICB-1,INB
+        CSUM=CSUM+MENT(I,J)
+  197       CONTINUE
+ 
+       IF(CSUM.LT.M(I))THEN
+        NENT(I)=0
+        MENT(I,I)=M(I)
+        QENT(I,I)=RR(1)-EP(I)*CLW(I)
+          UENT(I,I)=U(NK)
+          VENT(I,I)=V(NK)
+          DO J=1,NTRA
+           TRAENT(I,I,J)=TRA(NK,J)
+          END DO
+        ELIJ(I,I)=CLW(I)
+        SIJ(I,I)=1.0
+       END IF
+      END IF
+  200      CONTINUE
+ 
+ 
+ 
+***************************************************************
+**       CALCUL DES MENTS(I,J) ET DES QENTS(I,J)
+**************************************************************
+ 
+         DO im=1,nd
+         do jm=1,nd
+ 
+         QENTS(im,jm)=QENT(im,jm)
+         MENTS(im,jm)=MENT(im,jm)
+         enddo
+         enddo
+ 
+***********************************************************
+c--- test sb:
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c@       write(*,*) 'inb,m(inb),ment(inb,inb),sigij(inb,inb):'
+c@       write(*,*) inb,m(inb),ment(inb,inb),sigij(inb,inb)
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c---
+
+ 
+ 
+ 
+C
+C   ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
+C   ***             DOWNDRAFT CALCULATION                      ***
+C
+        IF(EP(INB).LT.0.0001)GOTO 405
+C
+C   ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
+C   ***                AND CONDENSED WATER FLUX                    ***
+C
+        WFLUX=0.0
+        TINV=1./3.
+C
+C    ***                    BEGIN DOWNDRAFT LOOP                    ***
+C
+        DO 400 I=INB,1,-1
+C
+C    ***              CALCULATE DETRAINED PRECIPITATION             ***
+C
+ 
+ 
+        WDTRAIN=10.0*EP(I)*M(I)*CLW(I)
+        IF(I.GT.1)THEN
+         DO 320 J=1,I-1
+       AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+  320    WDTRAIN=WDTRAIN+10.0*AWAT*MENT(J,I)
+        END IF
+C
+C    ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
+C    ***              ESTIMATES OF RP(I)AND RP(I-1)             ***
+C
+ 
+ 
+        WT(I)=45.0
+      IF(I.LT.INB)THEN
+       RP(I)=RP(I+1)+(CPD*(T(I+1)-T(I))+GZ(I+1)-GZ(I))/LV(I)
+       RP(I)=0.5*(RP(I)+RR(I))
+      END IF
+      RP(I)=AMAX1(RP(I),0.0)
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(INB)=RR(INB)
+      IF(I.EQ.1)THEN
+       AFAC=P(1)*(RS(1)-RP(1))/(1.0E4+2000.0*P(1)*RS(1))
+      ELSE
+       RP(I-1)=RP(I)+(CPD*(T(I)-T(I-1))+GZ(I)-GZ(I-1))/LV(I)
+       RP(I-1)=0.5*(RP(I-1)+RR(I-1))
+       RP(I-1)=AMIN1(RP(I-1),RS(I-1))
+       RP(I-1)=AMAX1(RP(I-1),0.0)
+       AFAC1=P(I)*(RS(I)-RP(I))/(1.0E4+2000.0*P(I)*RS(I))
+       AFAC2=P(I-1)*(RS(I-1)-RP(I-1))/(1.0E4+
+     1    2000.0*P(I-1)*RS(I-1))
+       AFAC=0.5*(AFAC1+AFAC2)
+      END IF
+      IF(I.EQ.INB)AFAC=0.0
+        AFAC=AMAX1(AFAC,0.0)
+        BFAC=1./(SIGD*WT(I))
+C
+Cjyg1
+CCC        SIGT=1.0
+CCC        IF(I.GE.ICB)SIGT=SIGP(I)
+C Prise en compte de la variation progressive de SIGT dans
+C les couches ICB et ICB-1:
+C 	Pour PLCL<PH(I+1), PR1=0 & PR2=1
+C 	Pour PLCL>PH(I),   PR1=1 & PR2=0
+C 	Pour PH(I+1)<PLCL<PH(I), PR1 est la proportion a cheval
+C    sur le nuage, et PR2 est la proportion sous la base du
+C    nuage.
+         PR1 =(PLCL-PH(I+1))/(PH(I)-PH(I+1))
+         PR1 = MAX(0.,MIN(1.,PR1))
+         PR2 = (PH(I)-PLCL)/(PH(I)-PH(I+1))
+         PR2 = MAX(0.,MIN(1.,PR2))
+         SIGT = SIGP(I)*PR1 + PR2
+c sb3d         print *,'i,sigt,pr1,pr2', i,sigt,pr1,pr2
+Cjyg2
+C
+        B6=BFAC*50.*SIGD*(PH(I)-PH(I+1))*SIGT*AFAC
+        C6=WATER(I+1)+BFAC*WDTRAIN-50.*SIGD*BFAC*
+     1   (PH(I)-PH(I+1))*EVAP(I+1)
+      IF(C6.GT.0.0)THEN
+         REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
+         EVAP(I)=SIGT*AFAC*REVAP
+         WATER(I)=REVAP*REVAP
+      ELSE
+       EVAP(I)=-EVAP(I+1)+0.02*(WDTRAIN+SIGD*WT(I)*
+     1    WATER(I+1))/(SIGD*(PH(I)-PH(I+1)))
+      END IF
+ 
+ 
+C
+C    ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
+C    ***              HYDROSTATIC APPROXIMATION                 ***
+C
+        IF(I.EQ.1)GOTO 360
+      TEVAP=AMAX1(0.0,EVAP(I))
+      DELTH=AMAX1(0.001,(TH(I)-TH(I-1)))
+      MP(I)=10.*LVCP(I)*SIGD*TEVAP*(P(I-1)-P(I))/DELTH
+C
+C    ***           IF HYDROSTATIC ASSUMPTION FAILS,             ***
+C    ***   SOLVE CUBIC DIFFERENCE EQUATION FOR DOWNDRAFT THETA  ***
+C    ***  AND MASS FLUX FROM TWO SIMULTANEOUS DIFFERENTIAL EQNS ***
+C
+      AMFAC=SIGD*SIGD*70.0*PH(I)*(P(I-1)-P(I))*
+     1   (TH(I)-TH(I-1))/(TV(I)*TH(I))
+      AMP2=ABS(MP(I+1)*MP(I+1)-MP(I)*MP(I))
+      IF(AMP2.GT.(0.1*AMFAC))THEN
+         XF=100.0*SIGD*SIGD*SIGD*(PH(I)-PH(I+1))
+         TF=B(I)-5.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         AF=XF*TF+MP(I+1)*MP(I+1)*TINV
+         BF=2.*(TINV*MP(I+1))**3+TINV*MP(I+1)*XF*TF+50.*
+     1    (P(I-1)-P(I))*XF*TEVAP
+         FAC2=1.0
+         IF(BF.LT.0.0)FAC2=-1.0
+         BF=ABS(BF)
+         UR=0.25*BF*BF-AF*AF*AF*TINV*TINV*TINV
+         IF(UR.GE.0.0)THEN
+          SRU=SQRT(UR)
+          FAC=1.0
+          IF((0.5*BF-SRU).LT.0.0)FAC=-1.0
+          MP(I)=MP(I+1)*TINV+(0.5*BF+SRU)**TINV+
+     1     FAC*(ABS(0.5*BF-SRU))**TINV
+         ELSE
+          D=ATAN(2.*SQRT(-UR)/(BF+1.0E-28))
+          IF(FAC2.LT.0.0)D=3.14159-D
+          MP(I)=MP(I+1)*TINV+2.*SQRT(AF*TINV)*COS(D*TINV)
+         END IF
+         MP(I)=AMAX1(0.0,MP(I))
+         B(I-1)=B(I)+100.0*(P(I-1)-P(I))*TEVAP/(MP(I)+SIGD*0.1)-
+     1    10.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         B(I-1)=AMAX1(B(I-1),0.0)
+      END IF
+ 
+ 
+C
+C   ***         LIMIT MAGNITUDE OF MP(I) TO MEET CFL CONDITION      ***
+C
+      AMPMAX=2.0*(PH(I)-PH(I+1))*DELTI
+      AMP2=2.0*(PH(I-1)-PH(I))*DELTI
+      AMPMAX=AMIN1(AMPMAX,AMP2)
+      MP(I)=AMIN1(MP(I),AMPMAX)
+C
+C    ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
+C    ***       BETWEEN CLOUD BASE AND THE SURFACE                   ***
+C
+          IF(P(I).GT.P(ICB))THEN
+           MP(I)=MP(ICB)*(P(1)-P(I))/(P(1)-P(ICB))
+          END IF
+  360   CONTINUE
+C
+C    ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
+C
+        IF(I.EQ.INB)GOTO 400
+      RP(I)=RR(I)
+        IF(MP(I).GT.MP(I+1))THEN
+        RP(I)=RP(I+1)*MP(I+1)+RR(I)*(MP(I)-MP(I+1))+
+     1       5.*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+EVAP(I))
+        RP(I)=RP(I)/MP(I)
+          UP(I)=UP(I+1)*MP(I+1)+U(I)*(MP(I)-MP(I+1))
+         UP(I)=UP(I)/MP(I)
+          VP(I)=VP(I+1)*MP(I+1)+V(I)*(MP(I)-MP(I+1))
+         VP(I)=VP(I)/MP(I)
+          DO J=1,NTRA
+           TRAP(I,J)=TRAP(I+1,J)*MP(I+1)+
+     s     TRAP(I,J)*(MP(I)-MP(I+1))
+           TRAP(I,J)=TRAP(I,J)/MP(I)
+          END DO
+        ELSE
+        IF(MP(I+1).GT.1.0E-16)THEN
+           RP(I)=RP(I+1)+5.0*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+
+     1      EVAP(I))/MP(I+1)
+            UP(I)=UP(I+1)
+            VP(I)=VP(I+1)
+            DO J=1,NTRA
+             TRAP(I,J)=TRAP(I+1,J)
+            END DO
+        END IF
+        END IF
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(I)=AMAX1(RP(I),0.0)
+  400   CONTINUE
+C
+C   ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
+C
+        PRECIP=WT(1)*SIGD*WATER(1)*8640.0
+
+c sb  ***  Calculate downdraft velocity scale and surface temperature and  ***
+c sb  ***                    water vapor fluctuations                      ***
+c sb		(inspire de convect 4.3)
+
+c       BETAD=10.0         
+       BETAD=5.0         
+       WD=BETAD*ABS(MP(ICB))*0.01*RD*T(ICB)/(SIGD*P(ICB))
+
+  405   CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
+C   ***                      AND MIXING RATIO                        ***
+C
+      DPINV=1.0/(PH(1)-PH(2))
+        AM=0.0
+        DO 410 K=2,INB
+  410   AM=AM+M(K)
+      IF((0.1*DPINV*AM).GE.DELTI)IFLAG=4
+      FT(1)=0.1*DPINV*AM*(T(2)-T(1)+(GZ(2)-GZ(1))/CPN(1))
+        FT(1)=FT(1)-0.5*LVCP(1)*SIGD*(EVAP(1)+EVAP(2))
+        FT(1)=FT(1)-0.09*SIGD*MP(2)*T(1)*B(1)*DPINV
+      FT(1)=FT(1)+0.01*SIGD*WT(1)*(CL-CPD)*WATER(2)*(T(2)-
+     1   T(1))*DPINV/CPN(1)
+        FR(1)=0.1*MP(2)*(RP(2)-RR(1))*
+Ccorrection bug conservation eau
+C    1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+     1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+cIM cf. SBL
+C    1    DPINV+SIGD*EVAP(1)
+        FR(1)=FR(1)+0.1*AM*(RR(2)-RR(1))*DPINV
+        FU(1)=FU(1)+0.1*DPINV*(MP(2)*(UP(2)-U(1))+AM*(U(2)-U(1)))
+        FV(1)=FV(1)+0.1*DPINV*(MP(2)*(VP(2)-V(1))+AM*(V(2)-V(1)))
+        DO J=1,NTRA
+         FTRA(1,J)=FTRA(1,J)+0.1*DPINV*(MP(2)*(TRAP(2,J)-TRA(1,J))+
+     1    AM*(TRA(2,J)-TRA(1,J)))
+        END DO
+        AMDE=0.0
+        DO 415 J=2,INB
+         FR(1)=FR(1)+0.1*DPINV*MENT(J,1)*(QENT(J,1)-RR(1))
+         FU(1)=FU(1)+0.1*DPINV*MENT(J,1)*(UENT(J,1)-U(1))
+         FV(1)=FV(1)+0.1*DPINV*MENT(J,1)*(VENT(J,1)-V(1))
+         DO K=1,NTRA
+          FTRA(1,K)=FTRA(1,K)+0.1*DPINV*MENT(J,1)*(TRAENT(J,1,K)-
+     1     TRA(1,K))
+         END DO
+  415      CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
+C   ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
+C
+C   ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
+C   ***                      THROUGH EACH LEVEL                          ***
+C
+ 
+ 
+        DO 500 I=2,INB
+        DPINV=1.0/(PH(I)-PH(I+1))
+      CPINV=1.0/CPN(I)
+        AMP1=0.0
+        DO 440 K=I+1,INB+1
+  440   AMP1=AMP1+M(K)
+        DO 450 K=1,I
+        DO 450 J=I+1,INB+1
+         AMP1=AMP1+MENT(K,J)
+  450   CONTINUE
+      IF((0.1*DPINV*AMP1).GE.DELTI)IFLAG=4
+        AD=0.0
+        DO 470 K=1,I-1
+        DO 470 J=I,INB
+  470   AD=AD+MENT(J,K)
+      FT(I)=0.1*DPINV*(AMP1*(T(I+1)-T(I)+(GZ(I+1)-GZ(I))*
+     1   CPINV)-AD*(T(I)-T(I-1)+(GZ(I)-GZ(I-1))*CPINV))
+     2   -0.5*SIGD*LVCP(I)*(EVAP(I)+EVAP(I+1))
+      RAT=CPN(I-1)*CPINV
+        FT(I)=FT(I)-0.09*SIGD*(MP(I+1)*T(I)*
+     1    B(I)-MP(I)*T(I-1)*RAT*B(I-1))*DPINV
+      FT(I)=FT(I)+0.1*DPINV*MENT(I,I)*(HP(I)-H(I)+
+     1    T(I)*(CPV-CPD)*(RR(I)-QENT(I,I)))*CPINV
+      FT(I)=FT(I)+0.01*SIGD*WT(I)*(CL-CPD)*WATER(I+1)*
+     1    (T(I+1)-T(I))*DPINV*CPINV
+        FR(I)=0.1*DPINV*(AMP1*(RR(I+1)-RR(I))-
+     1    AD*(RR(I)-RR(I-1)))
+        FU(I)=FU(I)+0.1*DPINV*(AMP1*(U(I+1)-U(I))-
+     1    AD*(U(I)-U(I-1)))
+        FV(I)=FV(I)+0.1*DPINV*(AMP1*(V(I+1)-V(I))-
+     1    AD*(V(I)-V(I-1)))
+        DO K=1,NTRA
+         FTRA(I,K)=FTRA(I,K)+0.1*DPINV*(AMP1*(TRA(I+1,K)-
+     1    TRA(I,K))-AD*(TRA(I,K)-TRA(I-1,K)))
+        END DO
+        DO 480 K=1,I-1
+       AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+         FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-AWAT
+     1    -RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+C (saturated updrafts resulting from mixing)      ! cld   
+         QCOND(I)=QCOND(I)+(ELIJ(K,I)-AWAT)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  480   CONTINUE
+      DO 490 K=I,INB
+       FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  490      CONTINUE
+        FR(I)=FR(I)+0.5*SIGD*(EVAP(I)+EVAP(I+1))+0.1*(MP(I+1)*
+     1    (RP(I+1)-RR(I))-MP(I)*(RP(I)-RR(I-1)))*DPINV
+        FU(I)=FU(I)+0.1*(MP(I+1)*(UP(I+1)-U(I))-MP(I)*
+     1    (UP(I)-U(I-1)))*DPINV
+        FV(I)=FV(I)+0.1*(MP(I+1)*(VP(I+1)-V(I))-MP(I)*
+     1    (VP(I)-V(I-1)))*DPINV
+        DO J=1,NTRA
+         FTRA(I,J)=FTRA(I,J)+0.1*DPINV*(MP(I+1)*(TRAP(I+1,J)-TRA(I,J))-
+     1    MP(I)*(TRAP(I,J)-TRAP(I-1,J)))
+        END DO
+C (saturated downdrafts resulting from mixing)    ! cld
+        DO K=I+1,INB                              ! cld
+         QCOND(I)=QCOND(I)+ELIJ(K,I)              ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDDO                                     ! cld
+C (particular case: no detraining level is found) ! cld
+        IF (NENT(I).EQ.0) THEN                    ! cld
+         QCOND(I)=QCOND(I)+(1-EP(I))*CLW(I)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDIF                                     ! cld
+        IF (NQCOND(I).NE.0.) THEN                 ! cld
+         QCOND(I)=QCOND(I)/NQCOND(I)              ! cld
+        ENDIF                                     ! cld
+  500   CONTINUE
+ 
+ 
+ 
+C
+C   ***   MOVE THE DETRAINMENT AT LEVEL INB DOWN TO LEVEL INB-1   ***
+C   ***        IN SUCH A WAY AS TO PRESERVE THE VERTICALLY        ***
+C   ***          INTEGRATED ENTHALPY AND WATER TENDENCIES         ***
+C
+c test sb:
+c@      write(*,*) '--------------------------------------------'
+c@      write(*,*) 'inb,ft,hp,h,t,rr,qent,ment,water,waterp,wt,mp,b'
+c@      write(*,*) inb,ft(inb),hp(inb),h(inb)
+c@     :   ,t(inb),rr(inb),qent(inb,inb)
+c@     :   ,ment(inb,inb),water(inb)
+c@     :   ,water(inb+1),wt(inb),mp(inb),b(inb)
+c@      write(*,*) '--------------------------------------------'
+c fin test sb:
+
+      AX=0.1*MENT(INB,INB)*(HP(INB)-H(INB)+T(INB)*
+     1    (CPV-CPD)*(RR(INB)-QENT(INB,INB)))/(CPN(INB)*
+     2    (PH(INB)-PH(INB+1)))
+      FT(INB)=FT(INB)-AX
+      FT(INB-1)=FT(INB-1)+AX*CPN(INB)*(PH(INB)-PH(INB+1))/
+     1    (CPN(INB-1)*(PH(INB-1)-PH(INB)))
+      BX=0.1*MENT(INB,INB)*(QENT(INB,INB)-RR(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FR(INB)=FR(INB)-BX
+      FR(INB-1)=FR(INB-1)+BX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      CX=0.1*MENT(INB,INB)*(UENT(INB,INB)-U(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FU(INB)=FU(INB)-CX
+      FU(INB-1)=FU(INB-1)+CX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DX=0.1*MENT(INB,INB)*(VENT(INB,INB)-V(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FV(INB)=FV(INB)-DX
+      FV(INB-1)=FV(INB-1)+DX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DO J=1,NTRA
+      EX=0.1*MENT(INB,INB)*(TRAENT(INB,INB,J)
+     1    -TRA(INB,J))/(PH(INB)-PH(INB+1))
+      FTRA(INB,J)=FTRA(INB,J)-EX
+      FTRA(INB-1,J)=FTRA(INB-1,J)+EX*
+     1     (PH(INB)-PH(INB+1))/(PH(INB-1)-PH(INB))
+      ENDDO   
+C
+C   ***    HOMOGINIZE TENDENCIES BELOW CLOUD BASE    ***
+C
+      ASUM=0.0
+      BSUM=0.0
+      CSUM=0.0
+        DSUM=0.0
+      DO 650 I=1,ICB-1
+       ASUM=ASUM+FT(I)*(PH(I)-PH(I+1))
+         BSUM=BSUM+FR(I)*(LV(I)+(CL-CPD)*(T(I)-T(1)))*
+     1    (PH(I)-PH(I+1))
+       CSUM=CSUM+(LV(I)+(CL-CPD)*(T(I)-T(1)))*(PH(I)-PH(I+1))
+       DSUM=DSUM+T(I)*(PH(I)-PH(I+1))/TH(I)
+  650      CONTINUE
+      DO 700 I=1,ICB-1
+       FT(I)=ASUM*T(I)/(TH(I)*DSUM)
+       FR(I)=BSUM/CSUM
+  700      CONTINUE
+C
+C   ***           RESET COUNTER AND RETURN           ***
+C
+      SIG(ND)=2.0
+c
+c
+      do i = 1, nd
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+c sb       dnwd0(i) = - mp(i)
+      enddo
+c
+      do i = 1, nl
+       dnwd0(i) = - mp(i)
+      enddo
+      do i = nl+1, nd
+       dnwd0(i) = 0.
+      enddo
+c
+      do i = icb, inb
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+
+         do k =i, inb
+            up1=0.0
+            dn1=0.0
+            do n = 1, i-1
+               up1 = up1 + ment(n,k)
+               dn1 = dn1 - ment(k,n)
+            enddo
+            upwd(i) = upwd(i)+ m(k) + up1
+            dnwd(i) = dnwd(i) + dn1
+         enddo
+        enddo
+ 
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        DETERMINATION DE LA VARIATION DE FLUX ASCENDANT ENTRE
+C        DEUX NIVEAU NON DILUE Mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+c sb      do i=1,ND
+c sb      Mike(i)=M(i)
+c sb      enddo
+ 
+      do i = 1, NL
+       Mike(i) = M(i)
+      enddo
+      do i = NL+1, ND
+       Mike(i) = 0.
+      enddo
+ 
+      do i=1,nd
+      Ma(i)=0
+      enddo
+ 
+c sb      do i=1,nd
+c sb      do j=i,nd
+c sb      Ma(i)=Ma(i)+M(j)
+c sb      enddo
+c sb      enddo
+
+      do i = 1, NL
+      do j = i, NL
+       Ma(i) = Ma(i) + M(j)
+      enddo
+      enddo
+c
+      do i = NL+1, ND
+       Ma(i) = 0.
+      enddo
+c 
+      do i=1,ICB-1
+      Ma(i)=0
+      enddo
+ 
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C        ICB REPRESENTE DE NIVEAU OU SE TROUVE LA
+c        BASE DU NUAGE , ET INB LE TOP DU NUAGE
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+       do i=1,ND
+       Mke(i)=upwd(i)+dnwd(i)
+       enddo
+
+C
+C   *** Diagnose the in-cloud mixing ratio   ***              ! cld
+C   ***           of condensed water         ***              ! cld
+C                                                             ! cld
+       DO I=1,ND                                              ! cld
+        MAA(I)=0.0                                            ! cld
+        WA(I)=0.0                                             ! cld
+        SIGA(I)=0.0                                           ! cld
+       ENDDO                                                  ! cld
+       DO I=NK,INB                                            ! cld
+       DO K=I+1,INB+1                                         ! cld
+        MAA(I)=MAA(I)+M(K)                                    ! cld
+       ENDDO                                                  ! cld
+       ENDDO                                                  ! cld
+       DO I=ICB,INB-1                                         ! cld
+        AXC(I)=0.                                             ! cld
+        DO J=ICB,I                                            ! cld
+         AXC(I)=AXC(I)+RD*(TVP(J)-TV(J))*(PH(J)-PH(J+1))/P(J) ! cld
+        ENDDO                                                 ! cld
+        IF (AXC(I).GT.0.0) THEN                               ! cld
+         WA(I)=SQRT(2.*AXC(I))                                ! cld
+        ENDIF                                                 ! cld
+       ENDDO                                                  ! cld
+       DO I=1,NL                                              ! cld
+        IF (WA(I).GT.0.0)                                     ! cld
+     1    SIGA(I)=MAA(I)/WA(I)*RD*TVP(I)/P(I)/100./DELTAC     ! cld
+        SIGA(I) = MIN(SIGA(I),1.0)                            ! cld
+        QCONDC(I)=SIGA(I)*CLW(I)*(1.-EP(I))                   ! cld
+     1          + (1.-SIGA(I))*QCOND(I)                       ! cld
+       ENDDO                                                  ! cld
+
+
+c@$$cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c@$$         call writeg1d(1,klev,ma,'ma  ','ma  ')
+c@$$          call writeg1d(1,klev,upwd,'upwd  ','upwd  ')
+c@$$          call writeg1d(1,klev,dnwd,'dnwd  ','dnwd  ')
+c@$$          call writeg1d(1,klev,dnwd0,'dnwd0  ','dnwd0  ')
+c@$$          call writeg1d(1,klev,tvp,'tvp  ','tvp  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,3),'tra3  ','tra3  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,4),'tra4  ','tra4  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,5),'tra5  ','tra5  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,6),'tra6  ','tra6  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,7),'tra7  ','tra7  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,8),'tra8  ','tra8  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,9),'tra9  ','tra9  ')
+c@$$          call writeg1d(1,klev,tra(1:klev,10),'tra10','tra10')
+c@$$          call writeg1d(1,klev,tra(1:klev,11),'tra11','tra11')
+c@$$          call writeg1d(1,klev,tra(1:klev,12),'tra12','tra12')
+c@$$          call writeg1d(1,klev,tra(1:klev,13),'tra13','tra13')
+c@$$          call writeg1d(1,klev,tra(1:klev,14),'tra14','tra14')
+c@$$          call writeg1d(1,klev,tra(1:klev,15),'tra15','tra15')
+c@$$          call writeg1d(1,klev,tra(1:klev,16),'tra16','tra16')
+c@$$          call writeg1d(1,klev,tra(1:klev,17),'tra17','tra17')
+c@$$          call writeg1d(1,klev,tra(1:klev,18),'tra18','tra18')
+c@$$          call writeg1d(1,klev,tra(1:klev,19),'tra19','tra19')
+c@$$          call writeg1d(1,klev,tra(1:klev,20),'tra20','tra20 ')
+c@$$          call writeg1d(1,klev,trap(1:klev,1),'trp1','trp1')
+c@$$          call writeg1d(1,klev,trap(1:klev,2),'trp2','trp2')
+c@$$          call writeg1d(1,klev,trap(1:klev,3),'trp3','trp3')
+c@$$          call writeg1d(1,klev,trap(1:klev,4),'trp4','trp4')
+c@$$          call writeg1d(1,klev,trap(1:klev,5),'trp5','trp5')
+c@$$          call writeg1d(1,klev,trap(1:klev,10),'trp10','trp10')
+c@$$          call writeg1d(1,klev,trap(1:klev,12),'trp12','trp12')
+c@$$          call writeg1d(1,klev,trap(1:klev,15),'trp15','trp15')
+c@$$          call writeg1d(1,klev,trap(1:klev,20),'trp20','trp20')
+c@$$          call writeg1d(1,klev,ftra(1:klev,1),'ftr1  ','ftr1  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,2),'ftr2  ','ftr2  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,3),'ftr3  ','ftr3  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,4),'ftr4  ','ftr4  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,5),'ftr5  ','ftr5  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,6),'ftr6  ','ftr6  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,7),'ftr7  ','ftr7  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,8),'ftr8  ','ftr8  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,9),'ftr9  ','ftr9  ')
+c@$$          call writeg1d(1,klev,ftra(1:klev,10),'ftr10','ftr10')
+c@$$          call writeg1d(1,klev,ftra(1:klev,11),'ftr11','ftr11')
+c@$$          call writeg1d(1,klev,ftra(1:klev,12),'ftr12','ftr12')
+c@$$          call writeg1d(1,klev,ftra(1:klev,13),'ftr13','ftr13')
+c@$$          call writeg1d(1,klev,ftra(1:klev,14),'ftr14','ftr14')
+c@$$          call writeg1d(1,klev,ftra(1:klev,15),'ftr15','ftr15')
+c@$$          call writeg1d(1,klev,ftra(1:klev,16),'ftr16','ftr16')
+c@$$          call writeg1d(1,klev,ftra(1:klev,17),'ftr17','ftr17')
+c@$$          call writeg1d(1,klev,ftra(1:klev,18),'ftr18','ftr18')
+c@$$          call writeg1d(1,klev,ftra(1:klev,19),'ftr19','ftr19')
+c@$$          call writeg1d(1,klev,ftra(1:klev,20),'ftr20','ftr20 ')
+c@$$          call writeg1d(1,klev,mp,'mp  ','mp ')
+c@$$          call writeg1d(1,klev,Mke,'Mke  ','Mke ')
+
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c
+        RETURN
+        END
+C ---------------------------------------------------------------------------
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cpl_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cpl_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cpl_mod.F90	(revision 984)
@@ -0,0 +1,1223 @@
+!
+! $Header$
+!
+MODULE cpl_mod
+!
+! This module excahanges and transforms all fields that should be recieved or sent to 
+! coupler. The transformation of the fields are done from the grid 1D-array in phylmd 
+! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each 
+! timestep is done in here. 
+!
+! Each type of surface that recevie fields from the coupler have a subroutine named 
+! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler 
+! have a subroutine named cpl_send_XXX_fields.
+!
+!*************************************************************************************
+
+! Use statements
+!*************************************************************************************
+  USE dimphy, ONLY : klon
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  USE iophy
+
+! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters 
+! in the module are compiled and not the subroutines.
+  USE oasis
+  USE write_field_phy
+  
+! Global attributes
+!*************************************************************************************
+  IMPLICIT NONE
+  PRIVATE
+
+  ! All subroutine are public except cpl_send_all and cpl_receive_all
+  PUBLIC :: cpl_init, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
+       cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
+       cpl_send_landice_fields, gath2cpl
+  
+
+! Declaration of module variables
+!*************************************************************************************
+! variable for coupling period
+  INTEGER, SAVE                             :: nexca
+  !$OMP THREADPRIVATE(nexca)
+
+! variables for cumulating fields during a coupling periode :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_sols, cpl_nsol, cpl_rain
+  !$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_snow, cpl_evap, cpl_tsol
+  !$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_fder, cpl_albe, cpl_taux
+  !$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp
+  !$OMP THREADPRIVATE(cpl_windsp)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_tauy
+  !$OMP THREADPRIVATE(cpl_tauy)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
+  !$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
+
+! variables read from coupler :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sst     ! sea surface temperature
+  !$OMP THREADPRIVATE(read_sst)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sit     ! sea ice temperature
+  !$OMP THREADPRIVATE(read_sit)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sic     ! sea ice fraction
+  !$OMP THREADPRIVATE(read_sic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_alb_sic ! albedo at sea ice
+  !$OMP THREADPRIVATE(read_alb_sic)
+  
+! fraction for different surface, saved during whole coupling period
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: pctsrf_sav   
+  !$OMP THREADPRIVATE(pctsrf_sav)
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: unity
+  !$OMP THREADPRIVATE(unity)
+  INTEGER, SAVE                             :: nidct, nidcs
+  !$OMP THREADPRIVATE(nidct,nidcs)
+
+! variables to be sent to the coupler
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
+  !$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
+  !$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
+  !$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
+  !$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp2D
+  !$OMP THREADPRIVATE(cpl_windsp2D)
+  
+
+CONTAINS
+!
+!************************************************************************************
+!
+  SUBROUTINE cpl_init(dtime, rlon, rlat)
+
+    INCLUDE "dimensions.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "control.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER                           :: error, sum_error, ig, i
+    INTEGER                           :: jf, nhoridct
+    INTEGER                           :: nhoridcs
+    INTEGER                           :: idtime
+    INTEGER                           :: idayref
+    INTEGER                           :: npas ! only for OASIS2
+    REAL                              :: zjulian
+    REAL, DIMENSION(iim,jjm+1)        :: zx_lon, zx_lat
+    CHARACTER(len = 20)               :: modname = 'cpl_init'
+    CHARACTER(len = 80)               :: abort_message
+    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
+
+!*************************************************************************************
+! Calculate coupling period
+!
+!*************************************************************************************
+     
+    npas = itaufin/ iphysiq
+    nexca = 86400 / dtime
+    WRITE(lunout,*)' ##### Ocean couple #####'
+    WRITE(lunout,*)' Valeurs des pas de temps'
+    WRITE(lunout,*)' npas = ', npas
+    WRITE(lunout,*)' nexca = ', nexca
+    
+!*************************************************************************************
+! Allocate variables
+!
+!*************************************************************************************
+    error = 0
+    sum_error = 0
+
+    ALLOCATE(unity(klon), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(pctsrf_sav(klon,nbsrf), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_sols(klon,2), stat = error) 
+    sum_error = sum_error + error
+    ALLOCATE(cpl_nsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rain(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_snow(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_evap(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_fder(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_albe(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_taux(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_windsp(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tauy(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sst(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sit(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+
+    IF (sum_error /= 0) THEN
+       abort_message='Pb allocation variables couplees'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+!*************************************************************************************
+! Initialize the allocated varaibles
+!
+!*************************************************************************************
+    DO ig = 1, klon
+       unity(ig) = ig
+    ENDDO
+    pctsrf_sav = 0.
+
+    cpl_sols = 0.   ; cpl_nsol = 0.  ; cpl_rain = 0.   ; cpl_snow = 0.
+    cpl_evap = 0.   ; cpl_tsol = 0.  ; cpl_fder = 0.   ; cpl_albe = 0.
+    cpl_taux = 0.   ; cpl_tauy = 0.  ; cpl_rriv2D = 0. ; cpl_rcoa2D = 0.
+    cpl_rlic2D = 0. ; cpl_windsp = 0.
+
+!*************************************************************************************
+! Initialize coupling
+!
+!*************************************************************************************
+    idtime = INT(dtime)
+#ifdef CPP_COUPLE
+    CALL inicma
+#endif
+
+!*************************************************************************************
+! initialize NetCDF output
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       idayref = day_ini
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+       DO i = 1, iim
+          zx_lon(i,1) = rlon(i+1)
+          zx_lon(i,jjm+1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+       clintocplnam="cpl_atm_tauflx"
+       CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
+            1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct) 
+! no vertical axis
+       CALL histdef(nidct, 'tauxe','tauxe', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tauyn','tauyn', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lon','tmp_lon', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lat','tmp_lat', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       DO jf=1,jpflda2o1 + jpflda2o2
+          CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
+               "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidct)
+       CALL histsync(nidct)
+       
+       clfromcplnam="cpl_atm_sst"
+       CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
+            0,zjulian,dtime,nhoridcs,nidcs) 
+! no vertical axis
+       DO jf=1,jpfldo2a
+          CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
+               "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       END DO
+       CALL histend(nidcs)
+       CALL histsync(nidcs)
+
+    ENDIF    ! is_sequential
+    
+  END SUBROUTINE cpl_init
+  
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_receive_all(itime, dtime, pctsrf)
+! This subroutine reads from coupler for both ocean and seaice
+! 4 fields : read_sst, read_sic, read_sit and read_alb_sic. 
+
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Local variables
+!************************************************************************************
+    INTEGER                                 :: j, ig, il_time_secs
+    INTEGER                                 :: itau_w
+    INTEGER, DIMENSION(iim*(jjm+1))         :: ndexcs
+    CHARACTER(len = 20)                     :: modname = 'cpl_receive_all'
+    CHARACTER(len = 80)                     :: abort_message
+    REAL, DIMENSION(klon)                   :: read_sic1D
+    REAL, DIMENSION(iim,jj_nb,jpfldo2a)  :: tab_read_flds
+    REAL, DIMENSION(iim,jj_nb)           :: read_sic
+
+!*************************************************************************************
+! Start calculation
+! Get fields from coupler
+!
+!*************************************************************************************
+
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL fromcpl(il_time_secs, tab_read_flds)
+#endif
+    
+! NetCDF output of received fields
+    IF (is_sequential) THEN
+       ndexcs(:) = 0
+       itau_w = itau_phy + itime
+       DO ig = 1, jpfldo2a
+          CALL histwrite(nidcs,cl_read(ig),itau_w,tab_read_flds(:,:,ig),iim*(jjm+1),ndexcs)
+       END DO
+    ENDIF
+
+! Save each field in a 2D array. 
+    read_sst(:,:)     = tab_read_flds(:,:,1)  ! Sea surface temperature
+    read_sic(:,:)     = tab_read_flds(:,:,2)  ! Sea ice concentration
+    read_alb_sic(:,:) = tab_read_flds(:,:,3)  ! Albedo at sea ice
+    read_sit(:,:)     = tab_read_flds(:,:,4)  ! Sea ice temperature
+
+!*************************************************************************************
+! Temperature and albedo are weighted with the fraction of sea-ice(read-sic)
+!
+!*************************************************************************************
+    DO j = 1, jj_nb
+       DO ig = 1, iim
+          IF (ABS(1. - read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = RTT - 1.8
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ELSE IF (ABS(read_sic(ig,j)) < 0.00001) THEN
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sst(ig,j)
+             read_alb_sic(ig,j) =  0.6
+          ELSE
+             read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+             read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+             read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          ENDIF
+       ENDDO
+    ENDDO
+    
+!*************************************************************************************
+!  Transform seaice fraction, read_sic into pctsrf_sav
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sic, read_sic1D, klon, unity)
+
+    DO ig = 1, klon
+       ! treatment only of ocean and/or seaice points
+       IF (pctsrf(ig,is_oce) > epsfra .OR. &
+            pctsrf(ig,is_sic) > epsfra) THEN
+          pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               * read_sic1D(ig)
+          pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+               - pctsrf_sav(ig,is_sic)
+       ENDIF
+    ENDDO
+
+!*************************************************************************************
+! To avoid round up problems
+!
+!*************************************************************************************
+    WHERE (ABS(pctsrf_sav(:,is_sic)) .LE. 2.*EPSILON(pctsrf_sav(1,is_sic)))
+       pctsrf_sav(:,is_sic) = 0.
+       pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+    ENDWHERE
+    WHERE (ABS(pctsrf_sav(:,is_oce)) .LE. 2.*EPSILON(pctsrf_sav(1,is_oce)))
+       pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+       pctsrf_sav(:,is_oce) = 0.
+    ENDWHERE
+    IF (MINVAL(pctsrf_sav(:,is_oce)) < 0.) THEN
+       WRITE(*,*)'Pb fraction ocean inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_oce))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_oce)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    IF (MINVAL(pctsrf_sav(:,is_sic)) < 0.) THEN
+       WRITE(*,*)'Pb fraction glace inferieure a 0'
+       WRITE(*,*)'au point ',MINLOC(pctsrf_sav(:,is_sic))
+       WRITE(*,*)'valeur = ',MINVAL(pctsrf_sav(:,is_sic)) 
+       abort_message = 'voir ci-dessus'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+        
+  END SUBROUTINE cpl_receive_all
+!
+!*************************************************************************************
+! 
+  SUBROUTINE cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf, &
+       tsurf_new, pctsrf_oce)
+!
+! This routine reads, if first time step in a coupling period, all fields reveived from
+! coupler for all types of surfaces. It returns the fields for the ocean surface which
+! are the sea surface temperature and the fraction of ocean. 
+! The fields are transformed into 1D arrays with valid points : 
+! tsurf_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, INTENT(IN)                        :: dtime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_oce
+
+!*************************************************************************************
+! If first time step in a coupling period receive all fields for all types
+! of surfaces from coupler : read_sst, read_sit, read_alb_sic and pctsrf_sav. 
+! 
+!*************************************************************************************
+
+    IF (MOD(itime, nexca) == 1) CALL cpl_receive_all(itime, dtime, pctsrf)
+
+
+!*************************************************************************************
+! Transform read_sst into compressed 1D variable tsurf_new
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sst, tsurf_new, knon, knindex)
+    pctsrf_oce(:) = pctsrf_sav(:,is_oce) 
+
+
+  END SUBROUTINE cpl_receive_ocean_fields
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl_receive_seaice_fields(knon, knindex, &
+       tsurf_new, alb_new, pctsrf_sic)
+!
+! This routine returns the fields for the seaice that have been read from the coupler
+! (done earlier with cpl_receive_ocean_fields). These fields are the temperature and 
+! albedo at sea ice surface and fraction of sea ice.
+! The fields are transformed into  1D arrays with valid points : 
+! tsurf_new(1:knon), alb_new(1:knon), pctsrf(1:klon).
+!
+    INCLUDE "indicesol.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: pctsrf_sic
+
+
+!*************************************************************************************
+! Transform fields read from coupler from 2D into compressed 1D variables
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sit, tsurf_new, knon, knindex)
+    CALL cpl2gath(read_alb_sic, alb_new, knon, knindex)
+    pctsrf_sic(:) = pctsrf_sav(:,is_sic) 
+
+  END SUBROUTINE cpl_receive_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder, albsol
+    REAL, DIMENSION(klon), INTENT(IN)       :: taux, tauy, windsp
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_ocean_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+!*************************************************************************************
+! Start calculation
+! The ocean points are saved with second array index=1
+!
+!*************************************************************************************
+    cpl_index = 1
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+       cpl_windsp(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+       cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
+            windsp(ig)      / FLOAT(nexca) 
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid. 
+! No sending to the coupler (it is done from cpl_send_seaice_fields).
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)!
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_windsp(1,cpl_index), cpl_windsp2D(1,1), &
+            knon, knindex)
+
+    ENDIF
+
+  END SUBROUTINE cpl_send_ocean_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. All fields for all types of surfaces are sent to
+! the coupler.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder
+    REAL, DIMENSION(klon), INTENT(IN)       :: albsol, taux, tauy
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+    LOGICAL, INTENT(IN)                     :: lafin
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_seaice_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+
+!*************************************************************************************
+! Start calulation
+! The sea-ice points are saved with second array index=2
+!
+!*************************************************************************************
+    cpl_index = 2
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(:,cpl_index) = 0.0
+       cpl_nsol(:,cpl_index) = 0.0
+       cpl_rain(:,cpl_index) = 0.0
+       cpl_snow(:,cpl_index) = 0.0
+       cpl_evap(:,cpl_index) = 0.0
+       cpl_tsol(:,cpl_index) = 0.0
+       cpl_fder(:,cpl_index) = 0.0
+       cpl_albe(:,cpl_index) = 0.0
+       cpl_taux(:,cpl_index) = 0.0
+       cpl_tauy(:,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / FLOAT(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / FLOAT(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / FLOAT(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / FLOAT(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / FLOAT(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / FLOAT(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / FLOAT(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / FLOAT(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / FLOAT(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / FLOAT(nexca)      
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid and all fields are sent to coupler.
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       CALL gath2cpl(cpl_sols(1,cpl_index), cpl_sols2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(1,cpl_index), cpl_nsol2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(1,cpl_index), cpl_rain2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(1,cpl_index), cpl_snow2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(1,cpl_index), cpl_evap2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(1,cpl_index), cpl_tsol2D(1,1, cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_fder(1,cpl_index), cpl_fder2D(1,1,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(1,cpl_index), cpl_albe2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(1,cpl_index), cpl_taux2D(1,1,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(1,cpl_index), cpl_tauy2D(1,1,cpl_index), &
+            knon, knindex)
+
+       ! Send all fields
+       CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+    ENDIF
+
+  END SUBROUTINE cpl_send_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rriv_in
+    REAL, DIMENSION(klon), INTENT(IN)         :: rcoa_in
+
+! Local variables
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rriv2D
+    REAL, DIMENSION(iim,jj_nb)             :: rcoa2D
+
+!*************************************************************************************
+! Rearrange fields in 2D variables 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rriv2D(:,:) = 0.0
+    rcoa2D(:,:) = 0.0
+    CALL gath2cpl(rriv_in, rriv2D, knon, knindex)
+    CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex)
+
+!*************************************************************************************
+! Reset cumulated fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rriv2D(:,:) = 0.0
+       cpl_rcoa2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Following fields should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / FLOAT(nexca)
+    cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_land_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in)
+! This subroutine cumulates the field for melting ice for each time-step 
+! during a coupling period. This routine will not send to coupler. Sending 
+! will be done in cpl_send_seaice_fields.
+!
+    INCLUDE "dimensions.h"
+    
+! Input varibales
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlic_in
+
+! Local varibales
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rlic2D
+
+!*************************************************************************************
+! Rearrange field in a 2D variable 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+    rlic2D(:,:) = 0.0
+    CALL gath2cpl(rlic_in, rlic2D, knon, knindex)
+
+!*************************************************************************************
+! Reset field to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_rlic2D(:,:) = 0.0
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Melting ice should be cumulated at each time-step
+!
+!*************************************************************************************    
+    cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / FLOAT(nexca)
+
+  END SUBROUTINE cpl_send_landice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+! This routine will send fields for all different surfaces to the coupler.
+! This subroutine should be executed after calculations by the last surface(sea-ice),
+! all calculations at the different surfaces have to be done before. 
+!    
+! Some includes
+!*************************************************************************************
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                                  :: itime
+    REAL, INTENT(IN)                                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)                    :: rlon, rlat
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)              :: pctsrf
+    LOGICAL, INTENT(IN)                                  :: lafin
+    
+! Local variables
+!*************************************************************************************
+    INTEGER                                              :: error, sum_error, j
+    INTEGER                                              :: itau_w
+    INTEGER                                              :: il_time_secs
+    INTEGER, DIMENSION(iim*(jjm+1))                      :: ndexct
+    REAL                                                 :: Up, Down
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_lon, tmp_lat
+    REAL, DIMENSION(iim, jj_nb, 4)                       :: pctsrf2D
+    REAL, DIMENSION(iim, jj_nb)                          :: deno
+    CHARACTER(len = 20)                                  :: modname = 'cpl_send_all'
+    CHARACTER(len = 80)                                  :: abort_message
+   
+! Variables with fields to coupler
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_taux
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_tauy
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_calv
+! Table with all fields to send to coupler
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2)     :: tab_flds
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
+#endif
+
+! End definitions
+!*************************************************************************************
+    
+
+
+!*************************************************************************************
+! All fields are stored in a table tab_flds(:,:,:)
+! First store the fields 7 to 18 which are already on the right format
+!
+!*************************************************************************************
+    tab_flds(:,:,7)  = cpl_windsp2D(:,:)
+    tab_flds(:,:,8)  = cpl_sols2D(:,:,2)
+    tab_flds(:,:,9)  = cpl_sols2D(:,:,1)
+    tab_flds(:,:,10) = cpl_nsol2D(:,:,2)
+    tab_flds(:,:,11) = cpl_nsol2D(:,:,1)
+    tab_flds(:,:,12) = cpl_fder2D(:,:,2)
+    tab_flds(:,:,13) = cpl_evap2D(:,:,2)
+    tab_flds(:,:,14) = cpl_evap2D(:,:,1)
+    tab_flds(:,:,17) = cpl_rcoa2D(:,:)
+    tab_flds(:,:,18) = cpl_rriv2D(:,:)
+    
+!*************************************************************************************
+! Transform the fraction of sub-surfaces from 1D to 2D array
+!
+!*************************************************************************************
+    pctsrf2D(:,:,:) = 0.
+    CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
+
+!*************************************************************************************
+! Calculate the average calving per latitude
+! Store calving in tab_flds(:,:,19)
+! 
+!*************************************************************************************      
+    DO j = 1, jj_nb
+       tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
+            pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
+    ENDDO
+    
+    
+    IF (is_parallel) THEN
+       IF (.NOT. is_north_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
+          CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_south_pole) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
+          CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
+#endif
+       ENDIF
+       
+       IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
+          Up=Up+tmp_calv(iim,1)
+          tmp_calv(:,1)=Up
+       ENDIF
+       
+       IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
+          Down=Down+tmp_calv(1,jj_nb)
+          tmp_calv(:,jj_nb)=Down	 
+       ENDIF
+    ENDIF
+      
+
+    tab_flds(:,:,19) = tmp_calv(:,:)
+
+!*************************************************************************************
+! Calculate total flux for snow, rain and wind with weighted addition using the 
+! fractions of ocean and seaice.
+!
+! Store the fields for rain and snow directly in tab_flds(:,:,15) and 
+! tab_flds(:,:,16) respectively.
+!
+!*************************************************************************************    
+    tab_flds(:,:,15) = 0.0
+    tab_flds(:,:,16) = 0.0
+    tmp_taux(:,:)    = 0.0
+    tmp_tauy(:,:)    = 0.0
+    
+
+    ! fraction oce+seaice
+    deno =  pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) 
+    ! For all valid grid cells containing some fraction of ocean or sea-ice
+    WHERE ( deno(:,:) /= 0 )
+       tab_flds(:,:,15) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       tab_flds(:,:,16) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       
+       tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+       tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+            cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+    ENDWHERE
+
+!*************************************************************************************
+! Transform the wind components from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates. 
+! Store the resulting wind components in tab_flds(:,:,1:6)
+!*************************************************************************************
+
+! Transform the longitudes and latitudes on 2D arrays
+    CALL Grid1DTo2D_mpi(rlon,tmp_lon)
+    CALL Grid1DTo2D_mpi(rlat,tmp_lat)
+    
+    IF (is_sequential) THEN
+       IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
+       IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
+    ENDIF
+      
+! NetCDF output of the wind before transformation of coordinate system
+    IF (is_sequential) THEN
+       ndexct(:) = 0
+       itau_w = itau_phy + itime
+       CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
+    ENDIF
+
+! Transform the wind from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates 
+    CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
+         tab_flds(:,:,1), tab_flds(:,:,2), tab_flds(:,:,3) )
+    
+    tab_flds(:,:,4)  = tab_flds(:,:,1)
+    tab_flds(:,:,5)  = tab_flds(:,:,2)
+    tab_flds(:,:,6)  = tab_flds(:,:,3)
+
+!*************************************************************************************
+! NetCDF output of all fields just before sending to coupler.
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       CALL histwrite(nidct,cl_writ(8), itau_w,tab_flds(:,:,8), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(9), itau_w,tab_flds(:,:,9), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(10),itau_w,tab_flds(:,:,10),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(11),itau_w,tab_flds(:,:,11),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(12),itau_w,tab_flds(:,:,12),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(13),itau_w,tab_flds(:,:,13),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(14),itau_w,tab_flds(:,:,14),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(15),itau_w,tab_flds(:,:,15),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(16),itau_w,tab_flds(:,:,16),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(17),itau_w,tab_flds(:,:,17),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(18),itau_w,tab_flds(:,:,18),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(19),itau_w,tab_flds(:,:,19),iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(1), itau_w,tab_flds(:,:,1), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(2), itau_w,tab_flds(:,:,2), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(3), itau_w,tab_flds(:,:,3), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(4), itau_w,tab_flds(:,:,4), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(5), itau_w,tab_flds(:,:,5), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(6), itau_w,tab_flds(:,:,6), iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,cl_writ(7), itau_w,tab_flds(:,:,7), iim*(jjm+1),ndexct)
+       CALL histsync(nidct)
+    ENDIF
+
+
+!*************************************************************************************
+! Send the table of all fields
+!
+!*************************************************************************************
+#ifdef CPP_COUPLE
+    il_time_secs=(itime-1)*dtime
+    CALL intocpl(il_time_secs, lafin, tab_flds(:,:,:))
+#endif
+
+!*************************************************************************************
+! Finish with some dellocate
+!
+!*************************************************************************************  
+    sum_error=0
+    DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, stat=error )
+    sum_error = sum_error + error
+    IF (sum_error /= 0) THEN
+       abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+  END SUBROUTINE cpl_send_all
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! 
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+
+! Input
+    INTEGER, INTENT(IN)                       :: knon
+    REAL, DIMENSION(iim,jj_nb), INTENT(IN)    :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+
+! Output
+    REAL, DIMENSION(klon), INTENT(OUT)        :: champ_out
+
+! Local
+    INTEGER                                   :: i, ig
+    REAL, DIMENSION(klon)                     :: tamp
+
+!*************************************************************************************
+!
+! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
+    CALL Grid2Dto1D_mpi(champ_in,tamp)
+
+! Compress from klon to knon
+    DO i = 1, knon
+       ig = knindex(i)
+       champ_out(i) = tamp(ig)
+    ENDDO
+
+  END SUBROUTINE cpl2gath
+!
+!*************************************************************************************
+!
+  SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                    :: knon
+    REAL, DIMENSION(klon), INTENT(IN)      :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)   :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                :: i, ig
+    REAL, DIMENSION(klon)                  :: tamp
+
+!*************************************************************************************
+
+! Decompress from knon to klon
+    tamp = 0.
+    DO i = 1, knon
+       ig = knindex(i)
+       tamp(ig) = champ_in(i)
+    ENDDO
+
+! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
+    CALL Grid1Dto2D_mpi(tamp,champ_out)
+    
+    IF (is_north_pole) champ_out(:,1)=tamp(1)
+    IF (is_south_pole) champ_out(:,jj_nb)=tamp(klon)
+    
+  END SUBROUTINE gath2cpl
+!
+!*************************************************************************************
+!
+END MODULE cpl_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cv3_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cv3_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cv3_routines.F	(revision 984)
@@ -0,0 +1,3145 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE cv3_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+C   ***                        OF CLOUD                         ***
+C
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+C
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cvparam3.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+c -- "microphysical" parameters:
+
+      sigd   = 0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+cIM cf. FH     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+      dttrig = 5.   ! (loose) condition for triggering 
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau    = 8000.
+      beta   = 1.0 - delt/tau
+      alpha  = 1.5E-3 * delt/tau
+c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end
+
+      SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+
+c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_feed(len,nd,t,q,qs,p,ph,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cvparam3.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+      real A, B ! convect3
+cym
+      plcl=0.0
+c@ !-------------------------------------------------------------------
+c@ ! --- Find level of minimum moist static energy
+c@ ! --- If level of minimum moist static energy coincides with
+c@ ! --- or is lower than minimum allowable parcel origin level,
+c@ ! --- set iflag to 6.
+c@ !-------------------------------------------------------------------
+c@ 
+c@       do 180 i=1,len
+c@        work(i)=1.0e12
+c@        ihmin(i)=nl
+c@  180  continue
+c@       do 200 k=2,nlp
+c@         do 190 i=1,len
+c@          if((hm(i,k).lt.work(i)).and.
+c@      &      (hm(i,k).lt.hm(i,k-1)))then
+c@            work(i)=hm(i,k)
+c@            ihmin(i)=k
+c@          endif
+c@  190    continue
+c@  200  continue
+c@       do 210 i=1,len
+c@         ihmin(i)=min(ihmin(i),nlm)
+c@         if(ihmin(i).le.minorig)then
+c@           iflag(i)=6
+c@         endif
+c@  210  continue
+c@ c
+c@ !-------------------------------------------------------------------
+c@ ! --- Find that model level below the level of minimum moist static
+c@ ! --- energy that has the maximum value of moist static energy
+c@ !-------------------------------------------------------------------
+c@  
+c@       do 220 i=1,len
+c@        work(i)=hm(i,minorig)
+c@        nk(i)=minorig
+c@  220  continue
+c@       do 240 k=minorig+1,nl
+c@         do 230 i=1,len
+c@          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+c@            work(i)=hm(i,k)
+c@            nk(i)=k
+c@          endif
+c@  230     continue
+c@  240  continue
+
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+  220    continue
+
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( t(i,nk(i)).lt.250.0    )
+     &       .or.( q(i,nk(i)).le.0.0      )     )
+c@      &       .or.( p(i,ihmin(i)).lt.400.0 )  )
+     &   .and.
+     &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+c ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+c ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 
+        endif ! iflag=7  
+
+ 260   continue
+
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute1(len,nd,t,q,qs,gz,plcl,p,nk,icb
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len)
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd) 
+      real plcl(len) ! convect3
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+c ori        ticb(i)=t(i,icb(i))
+c ori        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len              
+         ticb(i)=t(i,icb(i)+1)   
+         gzicb(i)=gz(i,icb(i)+1) 
+         qsicb(i)=qs(i,icb(i)+1) 
+        enddo                   
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp
+     o                ,pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cvparam3.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+c
+c   ***   make sure that column is dry adiabatic between the surface  ***
+c   ***    and cloud base, and that lifted air is positively buoyant  ***
+c   ***                         at cloud base                         ***
+c   ***       if not, return to calling program after resetting       ***
+c   ***                        sig(i) and w0(i)                       ***
+c
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = th(i,1)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cvparam3.h"
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd) 
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+c      do 121 j=1,ntra
+c      do 111 k=1,nd
+c       nn=0
+c      do 101 i=1,len
+c      if(iflag1(i).eq.0)then
+c       nn=nn+1
+c       tra(nn,k,j)=tra1(i,k,j)
+c      endif
+c 101  continue
+c 111  continue
+c 121  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c 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)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+c ori          if(k.ge.(nk(i)+1))then
+c ori            tca=tp(i,k)-t0
+c ori            if(tca.ge.0.0)then
+c ori              elacrit=elcrit
+c ori            else
+c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+c ori            endif
+c ori            elacrit=max(elacrit,0.0)
+c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+c ori            ep(i,k)=max(ep(i,k),0.0 )
+c ori            ep(i,k)=min(ep(i,k),1.0 )
+c ori            sigp(i,k)=sigs
+c ori          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c===================================================================== 
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k) 
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+cIM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
+       buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+ 510  continue
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+cym      do i=1,ncum*nlp
+cym       hp(i,1)=h(i,1)
+cym      enddo
+
+      do k=1,nlp
+        do i=1,ncum
+	  hp(i,k)=h(i,k)
+	enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end
+
+      SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb   
+c -------------------------------------------------------
+      
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=amax1(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+      
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),  
+c -- vertical velocity (w), fractional area covered by    
+c -- undilute updraft (sig), and updraft mass flux (m)  
+c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0 
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+
+
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=amax1(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv3_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+! 	- changer rr(il,1) -> qnk(il)
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c 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)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+cym            ment(i,k,j)=0.0
+cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+c      do k=1,ntra
+c       do j=1,nd  ! instead nlp
+c        do i=1,nd ! instead nlp
+c         do il=1,ncum
+c            traent(il,i,j,k)=tra(il,j,k)
+c         enddo
+c        enddo
+c       enddo
+c      enddo
+      zm(:,:)=0.
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il))
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il))
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+c       do k=1,ntra
+c        do j=minorig,nl
+c         do il=1,ncum
+c          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+c     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+c            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c          endif
+c         enddo
+c        enddo
+c       enddo
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then 
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i)
+      uent(il,i,i)=u(il,nk(il))
+      vent(il,i,i)=v(il,nk(il))
+      elij(il,i,i)=clw(il,i)
+cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+ 
+c      do j=1,ntra
+c       do i=minorig+1,nl
+c        do il=1,ncum
+c         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+c          traent(il,i,i,j)=tra(il,nk(il),j)
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+cym      call zilch(asum,ncum*nd)
+cym      call zilch(bsum,ncum*nd)
+cym      call zilch(csum,ncum*nd)
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl 
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=rr(il,1)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=u(il,nk(il))
+        vent(il,i,i)=v(il,nk(il))
+        elij(il,i,i)=clw(il,i)
+cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+c     :     .and. csum(il,i).lt.m(il,i) ) then
+c         traent(il,i,i,j)=tra(il,nk(il),j)
+c        endif
+c       enddo
+c      enddo
+789   continue
+c      
+c MAF: renormalisation de MENT
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+
+      SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl
+     :              ,mp,rp,up,vp,trap,wt,water,evap,b)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real th(nloc,na), gz(nloc,na)
+      real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real cpn(nloc,na), tv(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na)
+
+c local variables
+      integer i,j,k,il,num1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+
+c        do k=1,ntra
+c         do i=1,nd
+c          do il=1,ncum
+c           trap(il,i,k)=tra(il,i,k)
+c          enddo
+c         enddo
+c        enddo
+
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+ 
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+
+c
+c    ***                    begin downdraft loop                    ***
+c
+
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd*wt(il,i))
+c
+cjyg1
+ccc        sigt=1.0
+ccc        if(i.ge.icb)sigt=sigp(i)
+c prise en compte de la variation progressive de sigt dans
+c les couches icb et icb-1:
+c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+c 	pour plcl>ph(i),   pr1=1 & pr2=0
+c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+c    sur le nuage, et pr2 est la proportion sous la base du
+c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+      b6=bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :                -50.*sigd*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)
+     :            +0.02*(wdtrain(il)+sigd*wt(il,i)*water(il,i+1))
+     :                 /(sigd*(ph(il,i)-ph(il,i+1)))
+      end if
+c
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd*tevap
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+      endif
+c
+c    ***           if hydrostatic assumption fails,             ***
+c    ***   solve cubic difference equation for downdraft theta  ***
+c    ***  and mass flux from two simultaneous differential eqns ***
+c
+      amfac=sigd*sigd*70.0*ph(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,i))*xf*tevap
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante: 
+C il faut diviser par (mp(il,i)*sigd*grav) et non par (mp(il,i)+sigd*0.1). 
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+      if(p(il,i).gt.p(il,icb(il)))then
+       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+      endif
+
+360   continue
+      endif ! i.eq.1
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+c      do j=1,ntra
+c      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+ctestmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+c     :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
+c      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+c      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+c       do j=1,ntra
+c       trap(il,i,j)=trap(il,i+1,j)
+c       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end
+
+      SUBROUTINE cv3_yield(nloc,ncum,nd,na,ntra 
+     :                    ,icb,inb,delt
+     :                    ,t,rr,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b
+     :                    ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                    ,tv,tvp
+     :                    ,iflag,precip,VPrecip,ft,fr,fu,fv,ftra
+     :                    ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+cym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mike(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, awat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+
+      do il=1,ncum
+       precip(il)=0.0
+       wd(il)=0.0     ! gust
+       VPrecip(il,nd+1)=0.
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         VPrecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+
+c      do j=1,ntra
+c       do i=1,nd
+c        do il=1,ncum
+c          ftra(il,i,j)=0.0
+c        enddo
+c       enddo 
+c      enddo
+
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum 
+       if(ep(il,inb(il)).ge.0.0001)then 
+        if (cvflag_grav) then
+         precip(il)=wt(il,1)*sigd*water(il,1)*86400.*1000./(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd*water(il,1)*8640.
+        endif
+       endif 
+      enddo 
+
+C   ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
+C
+c MAF rajout pour lessivage
+       do k=1,nl
+         do il=1,ncum
+          if (k.le.inb(il)) then
+            if (cvflag_grav) then
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/grav
+            else
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/10.
+            endif 
+          endif
+         end do
+       end do
+C
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       am(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.le.inb(il)) then
+         am(il)=am(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+      do il=1,ncum
+
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+
+      ft(il,1)=ft(il,1)-0.5*lvcp(il,1)*sigd*(evap(il,1)+evap(il,2))
+
+      if (cvflag_grav) then
+       ft(il,1)=ft(il,1)-0.009*grav*sigd*mp(il,2)
+     :                             *t(il,1)*b(il,1)*work(il)
+      else
+       ft(il,1)=ft(il,1)-0.09*sigd*mp(il,2)*t(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd*wt(il,1)*(cl-cpd)*water(il,2)*(t(il,2)
+     :-t(il,1))*work(il)/cpn(il,1)
+
+      if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+c (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap) 
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+c+tard     :          +sigd*evap(il,1)
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      endif ! cvflag_grav
+
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (cvflag_grav) then
+c         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        else
+c         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        endif
+c       enddo
+c      enddo
+
+      do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il)) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+c      do k=1,ntra
+c       do j=2,nl
+c        do il=1,ncum
+c         if (j.le.inb(il)) then
+
+c          if (cvflag_grav) then
+c           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          else
+c           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          endif
+
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+c
+c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il))num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=i+1,nl+1
+       do 441 il=1,ncum
+        if (i.le.inb(il) .and. k.le.(inb(il)+1)) then
+         amp1(il)=amp1(il)+m(il,k)
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il)) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+      if (cvflag_grav) then
+       ft(il,i)=0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      else  ! cvflag_grav
+       ft(il,i)=0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      endif ! cvflag_grav
+
+
+      ft(il,i)=ft(il,i)+0.01*sigd*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t(il,i+1)-t(il,i))*dpinv*cpinv
+
+      if (cvflag_grav) then
+       fr(il,i)=0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+c      do k=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+c         if (cvflag_grav) then
+c           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         else
+c           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         endif
+c        endif
+c       enddo
+c      enddo
+
+      do 480 k=1,i-1
+       do 1370 il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+      awat=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+      awat=amax1(awat,0.0)
+
+      if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+c      do j=1,ntra
+c       do k=1,i-1
+c        do il=1,ncum
+c         if (i.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 490 k=i,nl+1
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav 
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav 
+        endif ! i and k
+1380   continue
+490   continue
+
+c      do j=1,ntra
+c       do k=i,nl+1
+c        do il=1,ncum
+c         if (i.le.inb(il) .and. k.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :         *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :             *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif ! i and k
+c        enddo
+c       enddo
+c      enddo
+
+      do 1400 il=1,ncum
+       if (i.le.inb(il)) then
+        dpinv=1.0/(ph(il,i)-ph(il,i+1))
+        cpinv=1.0/cpn(il,i)
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+
+         fu(il,i)=fu(il,i)+0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+         fu(il,i)=fu(il,i)+0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+      endif ! i
+1400  continue
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum 
+        if (k.le.inb(il) .and. i.le.inb(il)) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0.) then    ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+
+c         if (cvflag_grav) then
+c          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         else
+c          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         endif
+c        endif ! i
+c       enddo
+c      enddo 
+
+500   continue
+
+
+c   ***   move the detrainment at level inb down to level inb-1   ***
+c   ***        in such a way as to preserve the vertically        ***
+c   ***          integrated enthalpy and water tendencies         ***
+c
+      do 503 il=1,ncum
+
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))
+     : +t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+503   continue
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        ex=0.1*ment(il,inb(il),inb(il)) 
+c     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+c     :      /(ph(il,inb(il))-ph(il,inb(il)+1))
+c        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+c        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+c     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+c     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+c       enddo
+c      enddo
+
+c
+c   ***    homoginize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif 
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+      
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+m(il,k)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!     
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mike(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mike(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        icb represente de niveau ou se trouve la
+c        base du nuage , et inb le top du nuage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 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)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il) ) then                       ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+            
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0)                               ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+cIM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)              ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+        return
+        end
+
+      SUBROUTINE cv3_tracer(nloc,len,ncum,nd,na,
+     &                        ment,sij,da,phi)
+        implicit none
+c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sij(nloc,na,na)
+c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+c local variables:
+        integer i,j,k
+c        
+        da(:,:)=0.
+c
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+            da(i,j)=da(i,j)+(1.-sij(i,k,j))*ment(i,k,j)
+            phi(i,j,k)=sij(i,k,j)*ment(i,k,j)
+c            print *,'da',j,k,da(i,j),sij(i,k,j),ment(i,k,j)
+            end do 
+          end do 
+        end do 
+    
+        return
+        end
+
+
+      SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,VPrecip,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,inb
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,da,phi,mp
+     :         ,iflag1
+     :         ,precip1,VPrecip1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,inb1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :         ,da1,phi1,mp1)
+      implicit none
+
+#include "cvparam3.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      integer inb(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+      real da(nloc,nd),phi(nloc,nd,nd),mp(nloc,nd)
+
+c outputs:
+      integer iflag1(len)
+      integer inb1(len)
+      real precip1(len)
+      real VPrecip1(len,nd+1)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+      real da1(nloc,nd),phi1(nloc,nd,nd),mp1(nloc,nd)
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         inb1(idcum(i))=inb(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            VPrecip1(idcum(i),k)=VPrecip(i,k)
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            da1(idcum(i),k)=da(i,k)
+            mp1(idcum(i),k)=mp(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+c        do 2100 j=1,ntra
+c         do 2110 k=1,nd ! oct3
+c          do 2120 i=1,ncum
+c            ftra1(idcum(i),k,j)=ftra(i,k,j)
+c 2120     continue
+c 2110    continue
+c 2100   continue
+        do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            phi1(idcum(i),k,j)=phi(i,k,j)
+          end do
+         end do
+        end do
+
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cv_driver.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cv_driver.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cv_driver.F	(revision 984)
@@ -0,0 +1,705 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con,
+     &                   t1,q1,qs1,u1,v1,tra1,
+     &                   p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,VPrecip1,
+     &                   cbmf1,sig1,w01,
+     &                   icb1,inb1,
+     &                   delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1,
+     &                   da1,phi1,mp1)
+C
+      USE dimphy
+      implicit none
+C
+C.............................START PROLOGUE............................
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      iflag1        Integer        Output       flag for Emanuel conditions
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      VPrecip1      Real           Output       vertical profile of precipitations
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      delt          Real           Input        time step
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux 
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+C
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3) 
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2) 
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg) 
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      integer iflag_con
+      integer ntra
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real precip1(len)
+      real cbmf1(len)
+      real VPrecip1(len,nd+1)
+      real Ma1(len,nd)
+      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 da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+      real da(len,nd),phi(len,nd,nd),mp(len,nd)
+      real tra1(len,nd,ntra)
+      real ftra1(len,nd,ntra)
+
+      real delt
+
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  VPrecip: Vertical profile of convective precipitation (kg/m2/s).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+
+      integer i,k,n,il,j
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer inb1(klon)
+      integer icbs1(klon)
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev)
+      real cpn1(klon,klev)
+      real tv1(klon,klev)
+      real gz1(klon,klev)
+      real hm1(klon,klev)
+      real h1(klon,klev)
+      real tp1(klon,klev)
+      real tvp1(klon,klev)
+      real clw1(klon,klev)
+      real sig1(klon,klev)
+      real w01(klon,klev)
+      real th1(klon,klev)
+c
+      integer ncum
+c
+c (local) compressed fields:
+c
+cym      integer nloc
+cym      parameter (nloc=klon) ! pour l'instant
+#define nloc klon
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real sij(nloc,klev,klev), elij(nloc,klev,klev)
+      real qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+      real b(nloc,klev), ft(nloc,klev), fq(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+
+      nent(:,:)=0
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters 
+c
+c 	includes microphysical parameters and parameters that 
+c  	control the rate of approach to quasi-equilibrium) 
+c 	(common cvparam)
+
+      if (iflag_con.eq.3) then
+       CALL cv3_param(nd,delt)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft1(i,k)=0.0
+         fq1(i,k)=0.0
+         fu1(i,k)=0.0
+         fv1(i,k)=0.0
+         tvp1(i,k)=0.0
+         tp1(i,k)=0.0
+         clw1(i,k)=0.0
+cym
+         clw(i,k)=0.0	 
+         gz1(i,k) = 0.
+         VPrecip1(i,k) = 0.
+         Ma1(i,k)=0.0
+         upwd1(i,k)=0.0
+         dnwd1(i,k)=0.0
+         dnwd01(i,k)=0.0
+         qcondc1(i,k)=0.0
+ 10     continue
+ 20   continue
+
+      do 30 j=1,ntra
+       do 31 k=1,nd
+        do 32 i=1,len
+         ftra1(i,k,j)=0.0
+ 32     continue    
+ 31    continue    
+ 30   continue    
+
+      do 60 i=1,len
+        precip1(i)=0.0
+        iflag1(i)=0
+        wd1(i)=0.0
+        cape1(i)=0.0
+        VPrecip1(i,nd+1)=0.0
+ 60   continue
+
+      if (iflag_con.eq.3) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1            ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1           ! nd->na
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part 
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content. 
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1  ! nd->na
+     o                        ,tp1,tvp1,clw1,icbs1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+
+c       print*,'klon, ncum = ',len,ncum
+
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+       CALL cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+
+!-------------------------------------------------------------------
+! --- MIXING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                     ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,m,sig
+     o ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb    ! na->nd
+     :               ,t,q,qs,gz,u,v,tra,p,ph
+     :               ,th,tv,lv,cpn,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl
+     o          ,mp,qp,up,vp,trap,wt,water,evap,b)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b
+     :                     ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                     ,tv,tvp
+     o                     ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra
+     o                     ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+       CALL cv3_tracer(nloc,len,ncum,nd,nd,
+     :                  ment,sij,da,phi)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+c set iflag1 =42 for non convective points 
+      do  i=1,len
+        iflag1(i)=42
+      end do
+c
+      if (iflag_con.eq.3) then
+       CALL cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag
+     :          ,precip,VPrecip,sig,w0
+     :          ,ft,fq,fu,fv,ftra
+     :          ,inb 
+     :          ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :          ,da,phi,mp
+     o          ,iflag1
+     o          ,precip1,VPrecip1,sig1,w01
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,inb1
+     o          ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 
+     o          ,da1,phi1,mp1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc            
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )           
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_flag
+      implicit none
+
+#include "cvflag.h"
+
+c -- si .TRUE., on rend la gravite plus explicite et eventuellement
+c differente de 10.0 dans convect3: 
+      cvflag_grav = .TRUE.
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_thermo(iflag_con)
+	  implicit none
+
+c-------------------------------------------------------------
+c Set thermodynamical constants for convectL
+c-------------------------------------------------------------
+
+#include "YOMCST.h" 
+#include "cvthermo.h" 
+
+      integer iflag_con
+
+
+c original set from convect:
+      if (iflag_con.eq.4) then
+       cpd=1005.7
+       cpv=1870.0
+       cl=4190.0
+       rrv=461.5
+       rrd=287.04
+       lv0=2.501E6
+       g=9.8
+       t0=273.15
+       grav=g
+      endif
+
+c constants consistent with LMDZ:
+      if (iflag_con.eq.3) then
+       cpd = RCPD
+       cpv = RCPV
+       cl  = RCW
+       rrv = RV
+       rrd = RD
+       lv0 = RLVTT
+       g   = RG     ! not used in convect3
+c ori      t0  = RTT
+       t0  = 273.15 ! convect3 (RTT=273.16)
+c maf       grav= 10.    ! implicitely or explicitely used in convect3
+       grav= g    ! implicitely or explicitely used in convect3
+      endif
+
+      rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?)
+
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      cpvmcl=cl-cpv ! for convect3
+      eps=rrd/rrv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c      ginv=1.0/g
+      ginv=1.0/grav
+      hrd=0.5*rrd
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cv_routines.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cv_routines.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cv_routines.F	(revision 984)
@@ -0,0 +1,1755 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_param(nd)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL
+c (includes microphysical parameters and parameters that 
+c  control the rate of approach to quasi-equilibrium) 
+c------------------------------------------------------------
+
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+#include "cvparam.h"
+      integer nd
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+      noff = 2
+      minorig = 2
+
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      elcrit=0.0011
+      tlcrit=-55.0
+      entp=1.5
+      sigs=0.12
+      sigd=0.05
+      omtrain=50.0
+      omtsnow=5.5
+      coeffr=1.0
+      coeffs=0.8
+      dtmax=0.9
+c
+      cu=0.70
+c
+      betad=10.0
+c
+      damp=0.1
+      alpha=0.2
+c
+      delta=0.01  ! cld
+c
+      return
+      end
+
+      SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+
+c local variables:
+      integer k, i
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+
+      do 110 k=1,nlp
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C================================================================
+
+#include "cvparam.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax
+     :                       ,tp,tvp,clw)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len), icbmax
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd)
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-t0)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+      return
+      end
+
+      SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+#include "cvparam.h"
+
+c inputs:
+       integer len, nd, icb(len)
+       real cbmf(len), tv(len,nd), tvp(len,nd)
+
+c outputs:
+       integer iflag(len) ! also an input
+
+c local variables:
+       integer i
+
+
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+      return
+      end
+
+      SUBROUTINE cv_compress( len,nloc,ncum,nd
+     :   ,iflag1,nk1,icb1
+     :   ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :   ,t1,q1,qs1,u1,v1,gz1
+     :   ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o   ,iflag,nk,icb
+     o   ,cbmf,plcl,tnk,qnk,gznk
+     o   ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o   ,dph          )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len,ncum,nd,nloc
+      integer iflag1(len),nk1(len),icb1(len)
+      real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+
+c outputs:
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real dph(nloc,nd)
+
+c local variables:
+      integer i,k,nn
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      cbmf(nn)=cbmf1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      do 170 k=1,nl
+       do 160 i=1,ncum
+        dph(i,k)=ph(i,k)-ph(i,k+1)
+ 160   continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,dph,h,tv,lv
+     o                       ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd), dph(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+
+c outputs:
+      integer inb(nloc), inb1(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real frac(nloc)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=sigs
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-t0)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-t0)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-t0
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+c initialization:
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+        return
+        end
+c
+      SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb
+     :                     ,tv,tvp,p,ph,dph,plcl,cpn
+     :                     ,iflag,cbmf)
+      implicit none
+
+c inputs:
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc)
+      real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd)
+      real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent...
+      real plcl(nloc), cpn(nloc,nd)
+
+c outputs:
+      integer iflag(nloc)
+      real cbmf(nloc) ! also an input
+
+c local variables:
+      integer i, k, icbmax
+      real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+      real work(nloc)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c-------------------------------------------------------------------
+c Compute icbmax. 
+c-------------------------------------------------------------------
+
+      icbmax=2
+      do 230 i=1,ncum
+       icbmax=max(icbmax,icb(i))
+ 230  continue
+
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX 
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+
+       return
+       end
+
+      SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1
+     :                    ,ph,t,q,qs,u,v,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,cbmf
+     :                    ,m,ment,qent,uent,vent,nent,sij,elij)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+      real cbmf(nloc), qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd)
+      real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd)
+      real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd)
+
+c outputs:
+      integer nent(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real sij(nloc,nd,nd), elij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, ij
+      integer num1, num2
+      real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+      real alt, qp1, smid, sjmin, sjmax, delp, delm
+      real work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+      real bsum(nloc,nd)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          m(i,1)=0.0
+ 360    continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rrv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+       return
+       end
+
+      SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                  ,h,lv,ep,sigp,clw,m,ment,elij
+     :                  ,iflag,mp,qp,up,vp,wt,water,evap)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer inb(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd)
+      real gz(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd)
+
+c outputs:
+      integer iflag(nloc) ! also an input
+      real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+      real water(nloc,nd), evap(nloc,nd), wt(nloc,nd)
+
+c local variables:
+      integer i,j,k,ij,num1
+      integer jtt(nloc)
+      real awat, coeff, qsm, afac, sigt, b6, c6, revap
+      real dhdp, fac, qstm, rat
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c Initializations:
+c
+         do i = 1, ncum
+         do k = 1, nl+1
+          wt(i,k) = omtsnow
+          mp(i,k) = 0.0
+          evap(i,k) = 0.0
+          water(i,k) = 0.0
+         enddo
+         enddo
+
+         do 420 i=1,ncum
+          qp(i,1)=q(i,1)
+          up(i,1)=u(i,1)
+          vp(i,1)=v(i,1)
+ 420     continue
+
+         do 440 k=2,nl+1
+         do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430     continue
+ 440     continue
+
+
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+        return
+        end
+
+      SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :             ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :             ,ep,clw,frac,m,mp,qp,up,vp
+     :             ,wt,water,evap
+     :             ,ment,qent,uent,vent,nent,elij
+     :             ,tv,tvp
+     o             ,iflag,wd,qprime,tprime
+     o             ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc), inb(nloc)
+      integer nent(nloc,nd)
+      real delt
+      real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real gz(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real hp(nloc,nd), lv(nloc,nd)
+      real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc)
+      real m(nloc,nd), mp(nloc,nd), qp(nloc,nd)
+      real up(nloc,nd), vp(nloc,nd)
+      real wt(nloc,nd), water(nloc,nd), evap(nloc,nd)
+      real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c outputs
+      integer iflag(nloc)  ! also an input
+      real cbmf(nloc)      ! also an input
+      real wd(nloc), tprime(nloc), qprime(nloc)
+      real precip(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd)
+
+c local variables
+      integer i,j,ij,k,num1
+      real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti
+      real work(nloc), am(nloc),amp1(nloc),ad(nloc)
+      real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld
+      real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd)     ! cld
+
+ 
+c -- initializations:
+
+      delti = 1.0/delt
+
+      do 160 i=1,ncum
+      precip(i)=0.0
+      wd(i)=0.0
+      tprime(i)=0.0
+      qprime(i)=0.0
+       do 170 k=1,nl+1
+        ft(i,k)=0.0
+        fu(i,k)=0.0
+        fv(i,k)=0.0
+        fq(i,k)=0.0
+        lvcp(i,k)=lv(i,k)/cpn(i,k)
+        qcondc(i,k)=0.0              ! cld
+        qcond(i,k)=0.0               ! cld
+        nqcond(i,k)=0.0              ! cld
+ 170   continue
+ 160  continue
+
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+      do i=1,ncum
+       wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i))
+     :           /(sigd*p(i,icb(i)))
+       qprime(i)=0.5*(qp(i,1)-q(i,1))
+       tprime(i)=lv0*qprime(i)/cpd
+      enddo
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+c (saturated updrafts resulting from mixing)               ! cld
+               qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld
+               nqcond(ij,i)=nqcond(ij,i)+1.                ! cld
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+C (saturated downdrafts resulting from mixing)               ! cld
+            do k=i+1,inb(ij)                                 ! cld
+             qcond(ij,i)=qcond(ij,i)+elij(ij,k,i)            ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            enddo                                            ! cld
+C (particular case: no detraining level is found)            ! cld
+            if (nent(ij,i).eq.0) then                        ! cld
+             qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            endif                                            ! cld
+            if (nqcond(ij,i).ne.0.) then                     ! cld
+             qcond(ij,i)=qcond(ij,i)/nqcond(ij,i)            ! cld
+            endif                                            ! cld
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+             qcondc(i,k)=0.0                               ! cld
+           endif
+ 1910    continue
+ 1920   continue
+
+        do k=1,nl+1
+        do i=1,ncum
+          Ma(i,k) = 0.
+        enddo
+        enddo
+        do k=nl,1,-1
+        do i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        enddo
+        enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+      DO ij=1,ncum                                          ! cld   
+       do i=1,nd                                            ! cld 
+        mac(ij,i)=0.0                                       ! cld   
+        wa(ij,i)=0.0                                        ! cld
+        siga(ij,i)=0.0                                      ! cld
+       enddo                                                ! cld
+       do i=nk(ij),inb(ij)                                  ! cld
+       do k=i+1,inb(ij)+1                                   ! cld
+        mac(ij,i)=mac(ij,i)+m(ij,k)                         ! cld
+       enddo                                                ! cld
+       enddo                                                ! cld
+       do i=icb(ij),inb(ij)-1                               ! cld
+        ax(ij,i)=0.                                         ! cld
+        do j=icb(ij),i                                      ! cld
+         ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j))         ! cld   
+     :       *(ph(ij,j)-ph(ij,j+1))/p(ij,j)                 ! cld   
+        enddo                                               ! cld
+        if (ax(ij,i).gt.0.0) then                           ! cld   
+         wa(ij,i)=sqrt(2.*ax(ij,i))                         ! cld
+        endif                                               ! cld
+       enddo                                                ! cld
+       do i=1,nl                                            ! cld
+        if (wa(ij,i).gt.0.0)                                ! cld
+     :    siga(ij,i)=mac(ij,i)/wa(ij,i)                     ! cld   
+     :        *rrd*tvp(ij,i)/p(ij,i)/100./delta             ! cld   
+        siga(ij,i) = min(siga(ij,i),1.0)                    ! cld
+        qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i))     ! cld   
+     :          + (1.-siga(ij,i))*qcond(ij,i)               ! cld   
+       enddo                                                ! cld
+      ENDDO                                                 ! cld   
+
+        return
+        end
+
+      SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum
+     :         ,iflag
+     :         ,precip,cbmf
+     :         ,ft,fq,fu,fv
+     :         ,Ma,qcondc            
+     :         ,iflag1
+     :         ,precip1,cbmf1
+     :         ,ft1,fq1,fu1,fv1
+     :         ,Ma1,qcondc1            
+     :                               )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len, ncum, nd, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc), cbmf(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd) !cld
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len), cbmf1(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real Ma1(len,nd)
+      real qcondc1(len,nd) !cld
+
+c local variables:
+      integer i,k
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        return
+        end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cvflag.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cvflag.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cvflag.h	(revision 984)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      logical cvflag_grav
+
+      COMMON /cvflag/ cvflag_grav 
+c$OMP THREADPRIVATE(/cvflag/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cvltr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cvltr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cvltr.F	(revision 984)
@@ -0,0 +1,145 @@
+c
+c $Header$
+c
+      SUBROUTINE cvltr(pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx)
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : convection des traceurs / KE
+c Auteurs: M-A Filiberti and J-Y Grandpeix
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+      REAL paprs(klon,klev+1) ! pression aux 1/2 couches (bas en haut)
+      REAL pplay(klon,klev)  ! pression pour le milieu de chaque couche
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+      REAL upd(klon,klev)      ! saturated updraft mass flux
+      REAL dnd(klon,klev)      ! saturated downdraft mass flux
+c
+c--variables locales      
+      real zed(klon,klev),zmd(klon,klev,klev)
+      real za(klon,klev,klev)
+      real zmfd(klon,klev),zmfa(klon,klev)
+      real zmfp(klon,klev),zmfu(klon,klev)
+      integer i,k,j 
+c test conservation
+c      real conserv
+c =========================================
+c calcul des tendances liees au downdraft
+c =========================================
+      zed(:,:)=0.
+      zmfd(:,:)=0.
+      zmfa(:,:)=0.
+      zmfu(:,:)=0.
+      zmfp(:,:)=0.
+      zmd(:,:,:)=0.
+      za(:,:,:)=0.
+c entrainement
+      do k=1,klev-1
+        do i=1,klon
+          zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
+        end do
+      end do
+c
+c calcul de la matrice d echange
+c matrice de distribution de la masse entrainee en k
+c
+      do k=1,klev
+        do i=1,klon
+          zmd(i,k,k)=zed(i,k)
+        end do
+      end do
+      do k=2,klev
+        do j=k-1,1,-1
+          do i=1,klon
+          if(mp(i,j+1).ne.0) then
+          zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
+          endif
+          end do
+        end do
+      end do
+      do k=1,klev
+        do j=1,klev-1
+          do i=1,klon
+          za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+          end do
+        end do
+      end do
+c
+c rajout du terme lie a l ascendance induite
+c
+        do j=2,klev
+         do i=1,klon
+          za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+         end do
+        end do
+C
+c tendances
+c            
+      do k=1,klev
+        do j=1,klev
+          do i=1,klon
+          zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k)-x(i,j))
+          end do
+        end do
+      end do
+c
+c =========================================
+c calcul des tendances liees aux flux satures
+c =========================================
+      do j=1,klev
+        do i=1,klon
+          zmfa(i,j)=da(i,j)*(x(i,1)-x(i,j))
+        end do
+      end do
+      do k=1,klev
+        do j=1,klev
+          do i=1,klon
+          zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k)-x(i,j))
+          end do
+        end do
+      end do
+      do j=1,klev-1
+        do i=1,klon
+          zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1)-x(i,j))
+        end do
+      end do
+      do j=2,klev
+        do i=1,klon
+          zmfu(i,j)=zmfu(i,j)
+     .             +min(0.,upd(i,j)+dnd(i,j))*(x(i,j)-x(i,j-1))
+        end do
+      end do
+
+c =========================================
+c--calcul final des tendances
+c =========================================
+      do k=1, klev
+        do i=1, klon
+          dx(i,k)=(zmfd(i,k)+zmfu(i,k)
+     .      +zmfa(i,k)+zmfp(i,k))*pdtime
+     .      *RG/(paprs(i,k)-paprs(i,k+1))
+c          print*,'dx',k,dx(i,k)
+        enddo
+      enddo
+c
+c test de conservation du traceur
+c      conserv=0.
+c      do k=1, klev
+c        do i=1, klon
+c         conserv=conserv+dx(i,k)*
+c     .     (paprs(i,k)-paprs(i,k+1))/RG
+C
+c        enddo
+c      enddo
+c      print *,'conserv',conserv
+     
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cvparam.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cvparam.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cvparam.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+c------------------------------------------------------------
+c Parameters for convectL:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real elcrit, tlcrit
+      real entp
+      real sigs, sigd
+      real omtrain, omtsnow, coeffr, coeffs
+      real dtmax
+      real cu
+      real betad
+      real alpha, damp
+      real delta
+
+      COMMON /cvparam/ noff, minorig, nl, nlp, nlm
+     :                ,elcrit, tlcrit
+     :                ,entp, sigs, sigd
+     :                ,omtrain, omtsnow, coeffr, coeffs
+     :                ,dtmax, cu, betad, alpha, damp, delta
+
+c$OMP THREADPRIVATE(/cvparam/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cvparam3.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cvparam3.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cvparam3.h	(revision 984)
@@ -0,0 +1,30 @@
+!
+! $Header$
+!
+c------------------------------------------------------------
+c Parameters for convectL, iflag_con=3:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigd, spfac
+cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE   real pbcrit, ptcrit, epmax
+      real pbcrit, ptcrit
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha
+      real delta
+      real betad
+
+      COMMON /cvparam3/  noff, minorig, nl, nlp, nlm
+     :                ,  sigd, spfac
+cIM cf. FH : pour compatibilite avec conema3 TEMPORAIRE  :                ,pbcrit, ptcrit, epmax
+     :                ,pbcrit, ptcrit
+     :                ,omtrain
+     :                ,dtovsh, dpbase, dttrig
+     :                ,dtcrit, tau, beta, alpha, delta, betad
+
+c$OMP THREADPRIVATE(/cvparam3/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/cvthermo.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/cvthermo.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/cvthermo.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+c Thermodynamical constants for convectL:
+
+      real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+      real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl
+      real eps, epsi, epsim1
+      real ginv, hrd
+      real grav
+
+      COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+     :                 ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl 
+     :                 ,eps, epsi, epsim1, ginv, hrd, grav
+
+c$OMP THREADPRIVATE(/cvthermo/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/diagphy.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/diagphy.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/diagphy.F	(revision 984)
@@ -0,0 +1,411 @@
+!
+! $Header$
+!
+      SUBROUTINE diagphy(airephy,tit,iprt
+     $    , tops, topl, sols, soll, sens
+     $    , evap, rain_fall, snow_fall, ts
+     $    , d_etp_tot, d_qt_tot, d_ec_tot
+     $    , fs_bound, fq_bound)
+C======================================================================
+C
+C Purpose:
+C    Compute the thermal flux and the watter mass flux at the atmosphere
+c    boundaries. Print them and also the atmospheric enthalpy change and
+C    the  atmospheric mass change.
+C
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+C                   (i.e. -1 * flux absorbed by the surface)
+C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+C                   (i.e. flux emited - flux absorbed by the surface)
+C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+C                   (kg/m2/s), positive up
+C rain_fall(klon)
+C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+C snow_fall(klon)
+C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+C ts(klon)----input-R- Surface temperature (K)
+C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+C                    change (W/m2)
+C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+C                    change (kg/m2/s)
+C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+C                    change (W/m2)
+C
+C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+C
+C J.L. Dufresne, July 2002
+C======================================================================
+C 
+      implicit none
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+c     Output variables
+      REAL fs_bound, fq_bound
+C
+C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+C
+      integer i
+C
+      integer pas
+      save pas
+      data pas/0/
+c$OMP THREADPRIVATE(pas)
+C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+C
+C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+C     la glace, on travaille par difference a la chaleur specifique de l'
+c     air sec. En effet, comme on travaille a niveau de pression donne,
+C     toute variation de la masse d'un constituant est totalement
+c     compense par une variation de masse d'air.
+C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront
+     $         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice
+     $           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront
+     $    + slat
+C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+C
+      IF (iprt.ge.1) write(6,6666) 
+     $    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+C
+      IF (iprt.ge.1) write(6,6668) 
+     $    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+C
+      IF (iprt.ge.2) write(6,6667) 
+     $    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot
+     $    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end
+
+C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime
+     e  ,t,q,ql,qs,u,v,paprs,pplay
+     s  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la physique. Suppose que les niveau de
+c    pression entre couche ne varie pas entre 2 appels.
+C
+C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+c bilans sont sauvegardes dans des tableaux indices. On parlera
+C "d'indice de diagnostic"
+c 
+C
+c======================================================================
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c qs-------input-R- solid watter (kg/kg)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c paprs----input-R- pression a intercouche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C     other (COMMON...)
+C     RCPD, RCPV, ....
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+c$OMP THREADPRIVATE(pas)
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+c$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+c$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+c======================================================================
+C
+      DO k = 1, klev
+        DO i = 1, klon
+C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+C
+C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i) 
+     $        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*ql(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*qs(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+      RETURN 
+      END 
Index: LMDZ4/tags/LF_20080728/libf/phytherm/dimphy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/dimphy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/dimphy.F90	(revision 984)
@@ -0,0 +1,43 @@
+MODULE dimphy
+  
+  INTEGER,SAVE :: klon
+  INTEGER,SAVE :: kdlon
+  INTEGER,SAVE :: kfdia
+  INTEGER,SAVE :: kidia
+  INTEGER,SAVE :: nbtr 
+  INTEGER,SAVE :: klev
+  INTEGER,SAVE :: klevp1
+  INTEGER,SAVE :: klevm1
+  INTEGER,SAVE :: kflev
+
+!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
+  REAL,save,allocatable,dimension(:) :: zmasq
+!$OMP THREADPRIVATE(zmasq)   
+
+CONTAINS
+  
+  SUBROUTINE Init_dimphy(klon0,klev0,nbtr0)
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    INTEGER, INTENT(in) :: nbtr0
+    
+    klon=klon0
+    
+    kdlon=klon
+    kidia=1
+    kfdia=klon
+!$OMP MASTER 
+    klev=klev0
+    nbtr=nbtr0
+    klevp1=klev+1
+    klevm1=klev-1
+    kflev=klev
+!$OMP END MASTER    
+    ALLOCATE(zmasq(klon))    
+    
+  END SUBROUTINE Init_dimphy
+
+  
+END MODULE dimphy
Index: LMDZ4/tags/LF_20080728/libf/phytherm/dimphy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/dimphy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/dimphy.h	(revision 984)
@@ -0,0 +1,13 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2-1/jjm)
+      PARAMETER (KLON=KFDIA-KIDIA+1,KLEV=llm)
+!-----------------------------------------------------------------------
+      INTEGER nbtr ! nombre de vrais traceurs
+      PARAMETER (nbtr=nqmx-2+1/(nqmx-1))
+!-----------------------------------------------------------------------
+      REAL zmasq(KLON)
+      COMMON/terreoce/zmasq
Index: LMDZ4/tags/LF_20080728/libf/phytherm/dimsoil.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/dimsoil.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/dimsoil.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER nsoilmx
+      PARAMETER (nsoilmx=11)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ecribin.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ecribin.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ecribin.F	(revision 984)
@@ -0,0 +1,102 @@
+!
+! $Header$
+!
+      SUBROUTINE ecribins(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim +1,jjm+1)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim +1
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+            zz(iim+1,j)=zz(1,j)
+         ENDDO
+c-----------------------------------------------------------------------
+#ifdef VPP
+      CALL ecriture(unit,zz,(iim+1)*(jjm+1))
+#else
+      WRITE(unit) zz
+#endif
+c
+
+      RETURN
+      END
+      SUBROUTINE ecribina(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim+1,jjm+1,llm)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim +1
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+            zz(iim+1,j,ilay)=zz(1,j,ilay)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+#ifdef VPP
+         CALL ecriture(unit, zz(1,1,ilay), (iim+1)*(jjm+1))
+#else
+         WRITE(unit) ((zz(i,j,ilay),i=1,iim +1),j=1,jjm+1)
+#endif
+      ENDDO
+c
+      RETURN
+      END
+#ifdef VPP
+@OPTIONS NODOUBLE
+      SUBROUTINE ecriture(nunit, r8, n)
+      INTEGER nunit, n, i
+      REAL*8 r8(n)
+      REAL*4 r4(n)
+      DO i = 1, n
+         r4(i) = r8(i)
+      ENDDO
+      WRITE(nunit)r4
+      RETURN
+      END
+#endif
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ecrireg.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ecrireg.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ecrireg.F	(revision 984)
@@ -0,0 +1,119 @@
+!
+! $Header$
+!
+      SUBROUTINE ecriregs(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim,jjm+1)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+         ENDDO
+c-----------------------------------------------------------------------
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      RETURN
+      END
+      SUBROUTINE ecrirega(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim,jjm+1,llm)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp.F	(revision 984)
@@ -0,0 +1,542 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,ratqs,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl, rhcl)
+
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+#include "fisrtilp.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rhcl(klon,klev) ! humidite relative en ciel clair
+      REAL rain(klon) ! pluies (mm/s)
+      REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+cAA
+c Coeffients de fraction lessivee : pour OFF-LINE
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+      real zct(klon),zcl(klon)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+
+      INTEGER ninter ! sous-intervals pour la precipitation
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur
+
+      real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
+      real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon)
+      real erf
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c$OMP THREADPRIVATE(a_tr_sca)
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+      REAL zmair, zcpair, zcpeau
+C     Pour la conversion eau-neige
+      REAL zlh_solid(klon), zm_solid
+cIM 
+cym      INTEGER klevm1
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
+      fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
+c
+      DATA appel1er /.TRUE./
+cym
+      zdelq=0.0
+      
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+c         CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c  nexpo regle la raideur de la transition eau liquide / eau glace.
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+cIM : klevm1
+cym      klevm1=klev-1
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer la varition de temp. de l'air du a la chaleur sensible
+C transporter par la pluie.
+C Il resterait a rajouter cet effet de la chaleur sensible sur les
+C flux de surface, du a la diff. de temp. entre le 1er niveau et la
+C surface.
+C
+      DO i = 1, klon
+cIM
+       IF(k.LE.klevm1) THEN         
+        zmair=(paprs(i,k)-paprs(i,k+1))/RG
+        zcpair=RCPD*(1.0+RVTMP2*zq(i))
+        zcpeau=RCPD*RVTMP2
+        zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau
+     $      + zmair*zcpair*zt(i) )
+     $      / (zmair*zcpair + zrfl(i)*dtime*zcpeau)
+CC        WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1))
+       ENDIF
+      ENDDO
+c
+c
+c Calculer l'evaporation de la precipitation
+c
+
+
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+
+c pour la glace, on r�vapore toute la pr�ip dans la couche du dessous
+c la glace venant de la couche du dessus est simplement dans la couche
+c du dessous.
+
+         IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
+
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+
+c        print*,'Dans partiel k=',k
+c
+c   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
+c   nuageuse a partir des PDF de Sandrine Bony.
+c   rneb  : fraction nuageuse
+c   zqn   : eau totale dans le nuage
+c   zcond : eau condensee moyenne dans la maille.
+c           on prend en compte le r�hauffement qui diminue la partie condensee
+c
+c   Version avec les raqts
+
+         if (iflag_pdf.eq.0) then
+
+           do i=1,klon
+            zdelq = min(ratqs(i,k),0.99) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+           enddo
+
+         else
+c
+c   Version avec les nouvelles PDFs.
+           do i=1,klon
+              if(zq(i).lt.1.e-15) then
+                print*,'ZQ(',i,',',k,')=',zq(i)
+                zq(i)=1.e-15
+              endif
+           enddo
+           do i=1,klon
+            zpdf_sig(i)=ratqs(i,k)*zq(i)
+            zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+            zpdf_delta(i)=log(zq(i)/zqs(i))
+            zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+            zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+            zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+            zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
+            zpdf_e1(i)=1.-erf(zpdf_e1(i))
+            zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+            zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
+            zpdf_e2(i)=1.-erf(zpdf_e2(i))
+            if (zpdf_e1(i).lt.1.e-10) then
+               rneb(i,k)=0.
+               zqn(i)=zqs(i)
+            else
+               rneb(i,k)=0.5*zpdf_e1(i)
+               zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+            endif
+            
+           enddo
+
+        endif ! iflag_pdf
+
+         do i=1,klon
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+c           zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+c  On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par
+c  la convection.
+c  ATTENTION !!! Il va falloir verifier tout ca.
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+c           print*,'ZDQS ',zdqs(i)
+c--Olivier
+            rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0
+c--fin
+           ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+c         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+
+         if (ptconv(i,k)) then
+            zcl(i)=cld_lc_con
+            zct(i)=1./cld_tau_con
+         else
+            zcl(i)=cld_lc_lsc
+            zct(i)=1./cld_tau_lsc
+         endif
+c  quantit�d'eau ��minier.
+         zchau(i) = zct(i)*dtime/FLOAT(ninter) * zoliq(i)
+     .         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl(i))**2)) *(1.-zfice(i))
+c  meme chose pour la glace.
+         if (ptconv(i,k)) then
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvc(zrhol(i)) * zfice(i)
+         else
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvs(zrhol(i)) * zfice(i)
+         endif
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+      ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
+      ENDDO
+c
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
+cAA Lessivage par impaction dans les couches en-dessous
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
+c
+cAA----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+         zlh_solid(i) = RLSTT-RLVTT
+      ELSE
+         rain(i) = zrfl(i)
+         zlh_solid(i) = 0.
+      ENDIF
+      ENDDO
+C
+C For energy conservation : when snow is present, the solification
+c latent heat is considered.
+      DO k = 1, klev
+        DO i = 1, klon
+          zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
+          zmair=(paprs(i,k)-paprs(i,k+1))/RG
+          zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
+          d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair)
+        END DO 
+      END DO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp.h	(revision 984)
@@ -0,0 +1,28 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+      REAL cld_lc_lsc,cld_lc_con
+      REAL cld_tau_lsc,cld_tau_con
+      REAL ffallv_lsc,ffallv_con
+      REAL coef_eva
+      LOGICAL reevap_ice
+      INTEGER iflag_pdf
+
+      common/comfisrtilp/                                               &
+     &     cld_lc_lsc                                                   &
+     &     ,cld_lc_con                                                  &
+     &     ,cld_tau_lsc                                                 &
+     &     ,cld_tau_con                                                 &
+     &     ,ffallv_lsc                                                  &
+     &     ,ffallv_con                                                  &
+     &     ,coef_eva                                                    &
+     &     ,reevap_ice                                                  &
+     &     ,iflag_pdf        
+
+!$OMP THREADPRIVATE(/comfisrtilp/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp_tr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp_tr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/fisrtilp_tr.F	(revision 984)
@@ -0,0 +1,435 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,ratqs,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl,
+     s                   RHcl) ! relative humidity in clear sky (needed for aer optical properties; aeropt.F)
+
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rain(klon) ! pluies (mm/s)
+      REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      
+Cjq   For aerosol opt properties needed (see aeropt.F)
+      REAL RHcl(klon,klev)
+      
+cAA
+c Coeffients de fraction lessivee : pour OFF-LINE
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+      REAL ct ! inverse du temps pour qu'un nuage precipite
+      PARAMETER (ct=1./1800.)
+      REAL cl ! seuil de precipitation
+      PARAMETER (cl=2.6e-4)
+ccc      PARAMETER (cl=2.3e-4)
+ccc      PARAMETER (cl=2.0e-4)
+      INTEGER ninter ! sous-intervals pour la precipitation
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=2.0E-05)
+      LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      PARAMETER (calcrat=.TRUE.)
+      REAL zx_min, rat_max
+      PARAMETER (zx_min=1.0, rat_max=0.01)
+      REAL zx_max, rat_min
+      PARAMETER (zx_max=0.1, rat_min=0.3)
+      REAL zx
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c$OMP THREADPRIVATE(appel1er)
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c$OMP THREADPRIVATE(a_tr_sca)
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallv ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallv (zzz) = 3.29/2.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29 * ((zzz)**0.16)
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, calcrat:', calcrat
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+          CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer l'evaporation de la precipitation
+c
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+         DO i = 1, klon
+c
+            zdelq = ratqs(i,k) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+            
+c--Olivier
+            RHcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) RHcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) RHcl(i,k)=1.0
+c--fin
+            
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zchau(i) = ct*dtime/FLOAT(ninter) * zoliq(i)
+     .          * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i))
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+         zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallv(zrhol(i)) * zfice(i)
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+      ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
+      ENDDO
+c
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
+cAA Lessivage par impaction dans les couches en-dessous
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
+c
+cAA----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+      ELSE
+         rain(i) = zrfl(i)
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/flxtr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/flxtr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/flxtr.F	(revision 984)
@@ -0,0 +1,207 @@
+!
+! $Header$
+!
+      SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) 
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux, kcbot, kctop et kdtop
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --Un schema amont est choisi pour calculer les flux pour s'assurer 
+c   de la positivite des valeurs de traceurs, cela implique des eqs 
+c   differentes pour les flux de traceurs montants et descendants.
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant 
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+c--idem mais en variables locales
+      REAL zpen_u(klon,klev) 
+      REAL zpde_u(klon,klev)
+      REAL zpen_d(klon,klev) 
+      REAL zpde_d(klon,klev)
+c
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL pap(klon,klev)      ! pression aux couches (haut en bas)
+      REAL pt(klon,klev)       ! temperature aux couches (bas en haut) 
+      REAL zt(klon,klev)       ! temperature aux couches (haut en bas)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL paph(klon,klev+1)   ! pression aux 1/2 couches (haut en bas)
+      INTEGER kcbot(klon)      ! niveau de base de la convection
+      INTEGER kctop(klon)      ! niveau du sommet de la convection +1 
+      INTEGER kdtop(klon)      ! niveau de sommet du panache descendant
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL zx(klon,klev)       ! q de traceur (haut en bas)
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL xe(klon,klev)        ! q de traceurs dans l'environnement 
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+c
+c On remet les taux d'entrainement et de detrainement dans le panache
+c descendant a des valeurs positives. 
+c On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la 
+c conservation de la masse soit realisee a chaque niveau dans les 2 
+c panaches.
+      DO k=1, klev
+      DO i=1, klon
+        zpen_u(i,k)= pen_u(i,k)
+        zpde_u(i,k)= pde_u(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO k=1, klev-1
+      DO i=1, klon
+        zpen_d(i,k)=-pen_d(i,k+1)
+        zpde_d(i,k)=-pde_d(i,k+1)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon 
+      zpen_d(i,klev)       = 0.0
+      zpde_d(i,klev)       = -pmfd(i,klev)
+c   Correction 03 11 97
+c     zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      IF (kdtop(i).EQ.klev+1) THEN
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)
+      ELSE
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      ENDIF
+
+      zpde_u(i,kctop(i)-2) = pmfu(i,kctop(i)-1)
+      zpen_u(i,klev)       = pmfu(i,klev) 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=kcbot(i), klev-1
+      zpen_u(i,k) = pmfu(i,k) - pmfu(i,k+1)
+      ENDDO 
+      ENDDO 
+c
+c conversion des sens de notations bas-haut et haut-bas
+c
+      DO k=1, klev+1 
+      DO i=1, klon 
+        paph(i,klev+2-k)=paprs(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=1, klev 
+        pap(i,klev+1-k)=pplay(i,k)
+        zt(i,klev+1-k) =pt(i,k)
+        zx(i,klev+1-k) =x(i,k) 
+      ENDDO 
+      ENDDO
+c
+c--initialisations des flux de traceurs aux extremites de la colonne
+c
+      DO i=1, klon 
+        zmfux(i,klev+1) = 0.0 
+        zmfdx(i,1) = 0.0 
+        zmfex(i,1) = 0.0 
+      ENDDO
+c
+c--calcul des flux dans le panache montant
+c
+      DO k=klev, 1, -1
+      DO i=1, klon
+       IF (k.GE.kcbot(i)) THEN 
+         xu(i,k)=zx(i,k)
+         zmfux(i,k)=pmfu(i,k)*xu(i,k)
+       ELSE 
+         zmfux(i,k)= (zmfux(i,k+1) + zpen_u(i,k)*zx(i,k) ) / 
+     .               (1.+zpde_u(i,k)/MAX(zmfmin,pmfu(i,k)))
+         xu(i,k)=zmfux(i,k)/MAX(zmfmin,pmfu(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c--calcul des flux dans le panache descendant
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kdtop(i)-1) THEN
+         xd(i,k)=( zx(i,k)+xu(i,k) ) / 2. 
+         zmfdx(i,k+1)=pmfd(i,k+1)*xd(i,k)
+       ELSE
+         zmfdx(i,k+1)= (zmfdx(i,k) - zpen_d(i,k)*zx(i,k) ) /
+     .               (1.-zpde_d(i,k)/MIN(-zmfmin,pmfd(i,k+1)))
+         xd(i,k)=zmfdx(i,k+1)/MIN(-zmfmin,pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfdx(i,klev+1) = 0.0 
+         xd(i,klev) = (zpen_d(i,klev)*zx(i,klev) - zmfdx(i,klev)) / 
+     .                   MAX(zmfmin,zpde_d(i,klev)) 
+      ENDDO 
+c
+c--introduction du flux de retour dans l'environnement
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kctop(i)-3) THEN 
+         xe(i,k)= zx(i,k) 
+         zmfex(i,k+1)=-(pmfu(i,k+1)+pmfd(i,k+1))*xe(i,k)
+       ELSE 
+         zmfex(i,k+1)= (zmfex(i,k) - 
+     .      (zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i,k))) /
+     .      (1.-(zpen_d(i,k)+zpen_u(i,k))/
+     .      MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) )
+         xe(i,k)=zmfex(i,k+1)/MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfex(i,klev+1) = 0.0
+         xe(i,klev) = (zpde_u(i,klev)*xu(i,klev) + 
+     .                 zpde_d(i,klev)*xd(i,klev) -zmfex(i,klev)) /
+     .                 MAX(zmfmin,zpen_u(i,klev)+zpen_d(i,klev)) 
+      ENDDO
+c
+c--calcul final des tendances
+c
+      DO k=1 , klev
+      DO i=1, klon
+        dx(i,klev+1-k) = RG/(paph(i,k+1)-paph(i,k))*pdtime*
+     .                      ( zmfux(i,k+1) - zmfux(i,k) +
+     .                        zmfdx(i,k+1) - zmfdx(i,k) +
+     .                        zmfex(i,k+1) - zmfex(i,k) )
+      ENDDO
+      ENDDO
+c
+      RETURN 
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/fonte_neige_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/fonte_neige_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/fonte_neige_mod.F90	(revision 984)
@@ -0,0 +1,343 @@
+!
+! $Header$
+!
+MODULE fonte_neige_mod
+!
+! This module will treat the process of snow, melting, accumulating, calving, in 
+! case of simplified soil model.
+!
+!****************************************************************************************
+  USE dimphy, ONLY : klon
+
+  IMPLICIT NONE
+  SAVE
+
+! run_off_ter and run_off_lic are the runoff at the compressed grid knon for 
+! land and land-ice respectively
+! Note: run_off_lic is used in mod_landice and therfore not private
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_ter
+  !$OMP THREADPRIVATE(run_off_ter)
+  REAL, ALLOCATABLE, DIMENSION(:)             :: run_off_lic
+  !$OMP THREADPRIVATE(run_off_lic)
+
+! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_lic_0
+  !$OMP THREADPRIVATE(run_off_lic_0)
+  
+  REAL, PRIVATE                               :: tau_calv  
+  !$OMP THREADPRIVATE(tau_calv)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: ffonte_global
+  !$OMP THREADPRIVATE(ffonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqfonte_global
+  !$OMP THREADPRIVATE(fqfonte_global)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqcalving_global
+  !$OMP THREADPRIVATE(fqcalving_global)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_init(restart_runoff)
+
+! This subroutine allocates and initialize variables in the module. 
+! The variable run_off_lic_0 is initialized to the field read from
+! restart file. The other variables are initialized to zero.
+!
+    INCLUDE "indicesol.h"
+!****************************************************************************************
+! Input argument
+    REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff 
+
+! Local variables
+    INTEGER                           :: error
+    CHARACTER (len = 80)              :: abort_message 
+    CHARACTER (len = 20)              :: modname = 'fonte_neige_init'
+
+
+!****************************************************************************************
+! Allocate run-off at landice and initilize with field read from restart
+!
+!****************************************************************************************
+
+    ALLOCATE(run_off_lic_0(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic_0(:) = restart_runoff(:) 
+
+!****************************************************************************************
+! Allocate other variables and initilize to zero
+!
+!****************************************************************************************
+    ALLOCATE(run_off_ter(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_ter'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_ter(:) = 0.
+    
+    ALLOCATE(run_off_lic(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic(:) = 0.
+    
+    ALLOCATE(ffonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation ffonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    ffonte_global(:,:) = 0.0
+
+    ALLOCATE(fqfonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqfonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqfonte_global(:,:) = 0.0
+
+    ALLOCATE(fqcalving_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqcalving_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqcalving_global(:,:) = 0.0
+
+!****************************************************************************************
+! Read tau_calv
+!
+!****************************************************************************************
+    CALL conf_interface(tau_calv)
+
+
+  END SUBROUTINE fonte_neige_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, &
+       tsurf, precip_rain, precip_snow, &
+       snow, qsol, tsurf_new, evap)
+        
+! Routine de traitement de la fonte de la neige dans le cas du traitement
+! de sol simplifie!
+! LF 03/2001
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   knindex      index des mailles valables pour surface a traiter
+!   dtime        
+!   tsurf        temperature de surface
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!
+! input/output:
+!   snow         champs hauteur de neige
+!   qsol         hauteur d'eau contenu dans le sol
+!   tsurf_new    temperature au sol
+!   evap
+!
+  INCLUDE "indicesol.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "FCTTRE.h"
+  INCLUDE "clesphys.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, INTENT(IN)                  :: nisurf
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+    
+! Input/Output variables
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: qsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(INOUT) :: evap
+
+! Local variables
+!****************************************************************************************
+
+    INTEGER               :: i, j
+    REAL                  :: fq_fonte
+    REAL                  :: coeff_rel
+    REAL, PARAMETER       :: snow_max=3000.
+    REAL, PARAMETER       :: max_eau_sol = 150.0
+!! PB temporaire en attendant mieux pour le modele de neige
+! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15)
+    REAL, PARAMETER       :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!IM cf JLD/ GKtest
+    REAL, PARAMETER       :: chaice = 3.334E+05/(2.3867E+06*0.15)
+! fin GKtest
+    REAL, DIMENSION(klon) :: ffonte
+    REAL, DIMENSION(klon) :: fqcalving, fqfonte
+    REAL, DIMENSION(klon) :: d_ts
+    REAL, DIMENSION(klon) :: bil_eau_s, snow_evap
+
+    LOGICAL               :: neige_fond
+
+!****************************************************************************************
+! Start calculation
+! - Initialization
+!
+!****************************************************************************************
+    coeff_rel = dtime/(tau_calv * rday)
+    
+    bil_eau_s(:) = 0.
+
+!****************************************************************************************
+! - Increment snow due to precipitation and evaporation
+! - Calculate the water balance due to precipitation and evaporation (bil_eau_s)
+!
+!****************************************************************************************
+    WHERE (precip_snow > 0.) 
+       snow = snow + (precip_snow * dtime)
+    END WHERE
+
+    snow_evap = 0.
+    WHERE (evap > 0. ) 
+       snow_evap = MIN (snow / dtime, evap) 
+       snow = snow - snow_evap * dtime
+       snow = MAX(0.0, snow)
+    END WHERE
+    
+    bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime
+
+
+!****************************************************************************************
+! - Calculate melting snow
+! - Calculate calving and decrement snow, if there are to much snow
+! - Update temperature at surface
+!
+!****************************************************************************************
+
+    ffonte(:) = 0.0
+    fqcalving(:) = 0.0
+    fqfonte(:) = 0.0
+    DO i = 1, knon
+       ! Y'a-t-il fonte de neige?
+       neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+            .AND. tsurf_new(i) >= RTT)
+       IF (neige_fond) THEN
+          fq_fonte     = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
+          ffonte(i)    = fq_fonte * RLMLT/dtime
+          fqfonte(i)   = fq_fonte/dtime
+          snow(i)      = MAX(0., snow(i) - fq_fonte)
+          bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
+          tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+
+!IM cf JLD OK     
+!IM cf JLD/ GKtest fonte aussi pour la glace
+          IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN
+             fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0)
+             ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime
+             IF ( ok_lic_melt ) THEN
+                fqfonte(i) = fqfonte(i) + fq_fonte/dtime
+                bil_eau_s(i) = bil_eau_s(i) + fq_fonte
+             ENDIF
+             tsurf_new(i) = RTT
+          ENDIF
+          d_ts(i) = tsurf_new(i) - tsurf(i)
+       ENDIF
+
+       ! s'il y a une hauteur trop importante de neige, elle s'coule
+       fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime
+       snow(i)=MIN(snow(i),snow_max)
+    END DO
+
+
+    IF (nisurf == is_ter) THEN
+       DO i = 1, knon
+          qsol(i) = qsol(i) + bil_eau_s(i)
+          run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+          qsol(i) = MIN(qsol(i), max_eau_sol) 
+       END DO
+    ELSE IF (nisurf == is_lic) THEN
+       DO i = 1, knon
+          j = knindex(i)
+          run_off_lic(i)   = (coeff_rel *  fqcalving(i)) + &
+               (1. - coeff_rel) * run_off_lic_0(j)
+          run_off_lic_0(j) = run_off_lic(i)
+          run_off_lic(i)   = run_off_lic(i) + fqfonte(i)/dtime
+       END DO
+    ENDIF
+    
+!****************************************************************************************
+! Save ffonte, fqfonte and fqcalving in global arrays for each 
+! sub-surface separately
+!
+!****************************************************************************************
+    DO i = 1, knon
+       ffonte_global(knindex(i),nisurf)    = ffonte(i)
+       fqfonte_global(knindex(i),nisurf)   = fqfonte(i)
+       fqcalving_global(knindex(i),nisurf) = fqcalving(i)
+    ENDDO
+
+  END SUBROUTINE fonte_neige
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_final(restart_runoff)
+!
+! This subroutine returns run_off_lic_0 for later writing to restart file.
+!
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff
+
+!****************************************************************************************
+! Set the output variables
+    restart_runoff(:) = run_off_lic_0(:)
+
+! Deallocation of all varaibles in the module
+    DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, &
+         fqfonte_global, fqcalving_global)
+
+  END SUBROUTINE fonte_neige_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, &
+       fqfonte_out, ffonte_out)
+
+! Cumulate ffonte, fqfonte and fqcalving respectively for
+! all type of surfaces according to their fraction.
+!
+! This routine is called from physiq.F before histwrite.
+
+    INCLUDE "indicesol.h"
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqcalving_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqfonte_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: ffonte_out
+
+    INTEGER   :: nisurf
+!****************************************************************************************
+
+    ffonte_out(:)    = 0.0
+    fqfonte_out(:)   = 0.0
+    fqcalving_out(:) = 0.0
+
+    DO nisurf = 1, nbsrf
+       ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf)
+    ENDDO
+
+  END SUBROUTINE fonte_neige_get_vars
+!
+!****************************************************************************************
+!
+END MODULE fonte_neige_mod
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/haut2bas.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/haut2bas.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/haut2bas.F	(revision 984)
@@ -0,0 +1,19 @@
+!
+! $Header$
+!
+      SUBROUTINE haut2bas(klon, klev, varB2H, varH2B)
+      IMPLICIT NONE
+c
+      INTEGER klon, klev
+      REAL varB2H(klon, klev), varH2B(klon, klev)
+      INTEGER i, k, kinv
+c
+      DO k=1,klev  
+       kinv=klev-k+1 
+       DO i=1,klon
+        varH2B(i,k)=varB2H(i,kinv)
+       ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/hbtm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/hbtm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/hbtm.F	(revision 984)
@@ -0,0 +1,777 @@
+!
+! $Header$
+!
+
+      SUBROUTINE HBTM(knon, paprs, pplay,
+     .                t2m,t10m,q2m,q10m,ustar,
+     .                flux_t,flux_q,u,v,t,q,
+     .                pblh,cape,EauLiq,ctei,pblT,
+     .                therm,trmb1,trmb2,trmb3,plcl)
+        USE dimphy
+        IMPLICIT none
+
+c***************************************************************
+c*                                                             *
+c* HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
+c*                 JAS 47              BLM                     *
+c* Algorithme These Anne Mathieu                               *
+c* Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+c* written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+c* features : implem. exces Mathieu                            *
+c***************************************************************
+c* mods : decembre 99 passage th a niveau plus bas. voir fixer *
+c* la prise du th a z/Lambda = -.2 (max Ray)                   *
+c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
+c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
+c* voir aussi //KE pblh = niveau The_e ou l = env.             *
+c***************************************************************
+c* fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+c***************************************************************
+c*
+c
+c
+cAM Fev 2003
+c Adaptation a LMDZ version couplee
+c
+c Pour le moment on fait passer en argument les grdeurs de surface : 
+c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms 
+c on garde la possibilite de changer si besoin est (jusqu'a present la 
+c forme de HB avec le 1er niveau modele etait conservee)
+c
+c
+c
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL RLvCp, REPS
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+cAM
+      REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+      REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+      REAL ustar(klon)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL flux_t(klon,klev), flux_q(klon,klev)     ! Flux 
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+cAM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+cAM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+cum      PARAMETER (isommet=klev) ! limite max sommet pbl
+      REAL vk
+      PARAMETER (vk=0.35)     ! Von Karman => passer a .41 ! cf U.Olgstrom
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)     ! b calcul du Prandtl et de dTetas
+      REAL fakn
+      PARAMETER (fakn=7.2)    ! a
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)  ! pour Phim / h dans la S.L stable
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)   ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+      REAL sffrac
+      PARAMETER (sffrac=0.1)  ! S.L. = z/h < .1
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL q_star,t_star
+      REAL b1,b2,b212,b2sr     ! Lambert correlations T' q' avec T* q*
+      PARAMETER (b1=70.,b2=20.)
+c
+      REAL z(klon,klev)
+cAM      REAL pcfm(klon,klev), pcfh(klon,klev)
+cAM
+      REAL zref
+      PARAMETER (zref=2.)    ! Niveau de ref a 2m peut eventuellement 
+c                              etre choisi a 10m
+cMA
+c
+      INTEGER i, k, j
+      REAL zxt
+cAM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+cAM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
+      REAL pblh(klon)
+      REAL pblT(klon)
+      REAL plcl(klon)
+cAM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+cAM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+cAM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)     ! Monin-Obukhov lengh
+cAM      REAL ztvd, ztvu, 
+      REAL zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL trmb1(klon),trmb2(klon),trmb3(klon)
+C  Algorithme thermique
+      REAL s(klon,klev)     ! [P/Po]^Kappa milieux couches
+      REAL Th_th(klon)      ! potential temperature of thermal
+      REAL The_th(klon)     ! equivalent potential temperature of thermal
+      REAL qT_th(klon)      ! total water  of thermal
+      REAL Tbef(klon)       ! T thermique niveau precedent
+      REAL qsatbef(klon)
+      LOGICAL Zsat(klon)    ! le thermique est sature
+      REAL Cape(klon)       ! Cape du thermique
+      REAL Kape(klon)       ! Cape locale
+      REAL EauLiq(klon)     ! Eau liqu integr du thermique
+      REAL ctei(klon)       ! Critere d'instab d'entrainmt des nuages de CL
+      REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat
+cIM 091204 BEG
+      REAL a1,a2,a3
+cIM 091204 END
+      REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2
+      REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the
+      REAL delt_qt,delt_2,quadsat,spblh,reduc
+c
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5
+cAM      REAL zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+
+! initialisations (Anne)
+      isommet=klev
+      th_th(:) = 0.
+      q_star = 0
+      t_star = 0
+
+
+      b212=sqrt(b1*b2)
+      b2sr=sqrt(b2)
+c
+C ============================================================
+C     Fonctions thermo implicites
+C ============================================================
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c Tetens : pression partielle de vap d'eau e_sat(T)
+c =================================================
+C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
+C++ avec :
+C++ Tf = 273.16 K  (Temp de fusion de la glace)
+C++ r2 = 611.14 Pa
+C++ r3 = 17.269 (liquide) 21.875 (solide) adim
+C++ r4 = 35.86             7.66           Kelvin
+C++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
+C++ deriv� :
+C++ =========
+C++                   r3*(Tf-r4)*q_sat(T,p)
+C++ d_qsat_dT = --------------------------------
+C++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
+c++ pour zcvm5=Lv, c'est FOEDE
+c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
+C     ------------------------------------------------------------------
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+
+c
+c      DO i = 1, klon
+c         pcfh(i,1) = cd_h(i)
+c         pcfm(i,1) = cd_m(i)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         pcfh(i,k) = zkmin
+c         pcfm(i,k) = zkmin
+c         cgs(i,k) = 0.0
+c         cgh(i,k) = 0.0
+c         cgq(i,k) = 0.0
+c      ENDDO
+c      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
+c  pourquoi ne pas utiliser Phi/RG ?
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+         s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa
+      ENDDO
+c                                 s(k) = [pplay(k)/ps]^kappa
+c    + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+c
+c    -----------------  paprs <-> sig(k)
+c
+c    + + + + + + + + + pplay  <-> s(k-1)
+c
+c
+c    + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+c
+c    -----------------  paprs <-> sig(1)
+c
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+         s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa
+      ENDDO
+      ENDDO
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++  Determination des grandeurs de surface  +++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      DO i = 1, knon
+cAM         IF (thermcep) THEN
+cAM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+c           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+c           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+cAM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+cAM           zxqs=MIN(0.5,zxqs)
+cAM           zcor=1./(1.-retv*zxqs)
+cAM           zxqs=zxqs*zcor
+cAM         ELSE
+cAM           IF (tsol(i).LT.t_coup) THEN
+cAM              zxqs = qsats(tsol(i)) / paprs(i,1)
+cAM           ELSE
+cAM              zxqs = qsatl(tsol(i)) / paprs(i,1)
+cAM           ENDIF
+cAM         ENDIF
+c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique
+cAM        zx_alf1 = 1.0
+cAM        zx_alf2 = 1.0 - zx_alf1
+cAM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .        *(1.+RETV*q(i,1))*zx_alf1
+cAM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+cAM     .        *(1.+RETV*q(i,2))*zx_alf2
+cAM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+cAM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+cAM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+cAM      
+cAMAM           zxu = u10m(i)
+cAMAM           zxv = v10m(i)
+cAMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
+cAM Niveau de ref choisi a 2m
+        zxt = t2m(i)
+
+c ***************************************************
+c attention, il doit s'agir de <w'theta'>
+c   ;Calcul de tcls virtuel et de w'theta'virtuel
+c   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+c   tcls=tcls*(1+.608*qcls)
+c
+c   ;Pour avoir w'theta',
+c   ; il faut diviser par ro.Cp
+c   Cp=Cpd*(1+0.84*qcls)
+c   fcs=fcs/(ro_surf*Cp)
+c   ;On transforme w'theta' en w'thetav'
+c   Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+c   xle=xle/(ro_surf*Lv)
+c   fcsv=fcs+.608*xle*tcls
+c ***************************************************
+cAM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+cAM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+cAM
+cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+cAM calcule de Ro = paprs(i,1)/Rd zxt
+cAM convention >0 vers le bas ds lmdz 
+        khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1))
+        kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1))
+cAM   verifier que khfs et kqfs sont bien de la forme w'l'
+        heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
+c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+cAM        heatv(i) = khfs(i)
+cAM ustar est en entree
+cAM        taux = zxu *zxmod*cd_m(i)
+cAM        tauy = zxv *zxmod*cd_m(i)
+cAM        ustar(i) = SQRT(taux**2+tauy**2)
+cAM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+c Theta et qT du thermique sans exces (interpolin vers surf)
+c chgt de niveau du thermique (jeudi 30/12/1999)
+c (interpolation lineaire avant integration phi_h)
+cAM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
+cAM        qT_th(i) = max(qT_th(i),q(i,1))
+        qT_th(i) = q2m(i)
+cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
+cn reste a regler convention P) pour Theta
+c        The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+c     -                      + RLvCp*qT_th(i)
+cAM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+        Th_th(i) = t2m(i)
+      ENDDO
+c
+      DO i = 1, knon
+         rhino(i,1) = 0.0   ! Global Richardson
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)   ! on initialise pblh a l'altitude du 1er niveau
+         plcl(i) = 6000.
+c Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+         trmb1(i)   = 0.
+         trmb2(i)   = 0.
+         trmb3(i) = 0.
+      ENDDO
+
+C
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      fac = 100.0
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
+c passer par Theta_e et virpot)
+c         zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
+cAM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i))
+c  Le Ri par Theta_v
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+cAM On a nveau de ref a 2m ???
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+c ***************************************************
+c Wm ? et W* ? c'est la formule pour z/h < .1
+c   ;Calcul de w* ;;
+c   ;;;;;;;;;;;;;;;;
+c   w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
+c   ;; CALCUL DE wm ;;
+c   ;;;;;;;;;;;;;;;;;;
+c   ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
+c   ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+c   ;;;;;;;;;;;Dans la couche de surface
+c   if (z(ind) le 20) then begin
+c   Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+c   wm=u_star/Phim
+c   ;;;;;;;;;;;En dehors de la couche de surface
+c   endif else if (z(ind) gt 20) then begin
+c   wm=(u_star^3+c1*w_star^3)^(1/3.)
+c   endif
+c ***************************************************
+        wm(i)= ustar(i)*phiminv(i)
+c======================================================================
+cvaleurs de Dominique Lambert de la campagne SEMAPHORE :
+c <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+c <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
+c et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+c avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+c(leur corellation pourrait dependre de beta par ex)
+c  if fcsv(i,j) gt 0 then begin
+c    dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+c    (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+c    2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
+c    dqs=b2*(xle(i,j)/wm(i,j))^2
+c    theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+c    q_s(i,j)=q_10(i,j)+sqrt(dqs)
+c  endif else begin
+c    Theta_s(i,j)=thetav_10(i,j)
+c    q_s(i,j)=q_10(i,j)
+c  endelse
+c======================================================================
+c
+cHBTM        therm(i) = heatv(i)*fak/wm(i)
+c forme Mathieu :
+        q_star = kqfs(i)/wm(i)
+        t_star = khfs(i)/wm(i)
+cIM 091204 BEG
+        IF(1.EQ.0) THEN
+        IF(t_star.LT.0..OR.q_star.LT.0.) THEN
+          print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star,
+     $    khfs(i),kqfs(i),wm(i)
+        ENDIF
+        ENDIF
+cIM 091204 END
+cAM Nveau cde ref 2m =>
+cAM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
+cAM     +             + (RETV*T(i,1))**2*b2*q_star**2
+cAM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
+cAM     +                 )
+cIM 091204 BEG
+        a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2
+        a2=(RETV*Th_th(i))**2*b2*q_star*q_star
+        a3=2.*RETV*Th_th(i)*b212*q_star*t_star
+        aa=a1+a2+a3
+        IF(1.EQ.0) THEN
+        IF (aa.LT.0.) THEN 
+         print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa
+         print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212',
+     $   i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212
+        ENDIF
+        ENDIF
+cIM 091204 END
+        therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     +             + (RETV*Th_th(i))**2*b2*q_star*q_star
+cIM 101204  +             + 2.*RETV*Th_th(i)*b212*q_star*t_star
+     +             + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star)
+     +                 )
+c
+c Theta et qT du thermique (forme H&B) avec exces
+c (attention, on ajoute therm(i) qui est virtuelle ...)
+c pourquoi pas sqrt(b1)*t_star ?
+c        dqs = b2sr*kqfs(i)/wm(i)
+        qT_th(i) = qT_th(i)  + b2sr*q_star
+cnew on differre le calcul de Theta_e
+c        The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+        rhino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++ Improve pblh estimate for unstable conditions using the +++++++
+C ++          convective temperature excess :                +++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c et therm Theta_v (avec hypothese de constance de H&B,
+c         zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i)
+
+c
+c  Le Ri par Theta_v
+cAM Niveau de ref 2m
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+cIM 170305 BEG
+      IF(1.EQ.0) THEN
+c debug print -120;34       -34-        58 et    0;26 wamp
+      if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then
+            print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i)
+            q_star = kqfs(i)/wm(i)
+            t_star = khfs(i)/wm(i)
+            print*,'q* t*, b1,b2,b212 ',q_star,t_star
+     -            , b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     -            , (RETV*Th_th(i))**2*b2*q_star**2
+     -            , 2.*RETV*Th_th(i)*b212*q_star*t_star
+            print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2
+      endif
+      ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+c             q_star = kqfs(i)/wm(i)
+c             t_star = khfs(i)/wm(i)
+c             trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
+c             trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
+c Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+c par exemple :
+        pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
+     .              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+      ENDDO
+
+C ********************************************************************
+C  pblh is now available; do preparation for diffusivity calculation :
+C ********************************************************************
+      DO i = 1, knon
+        check(i) = .TRUE.
+        Zsat(i)   = .FALSE.
+c omegafl utilise pour prolongement CAPE
+        omegafl(i) = .FALSE.
+        Cape(i)   = 0.
+        Kape(i)   = 0.
+        EauLiq(i) = 0.
+        CTEI(i)   = 0.
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C *** Rq: les formule sont prises dans leur forme CS ***
+        IF (unstbl(i)) THEN
+cAM Niveau de ref du thermique
+cAM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .         *(1.+RETV*q(i,1))
+          zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i)))
+     .         *(1.+RETV*qT_th(i))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+c Computes Theta_e for thermal (all cases : to be modified)
+c   attention ajout therm(i) = virtuelle
+        The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+C debug
+c          if (i.EQ.1864) then
+c             print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
+c          endif
+
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+c        print*,'fin calcul niveaux'
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms zero'
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+c            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+c            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+c            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms non zero'
+C
+C For all unstable layers, compute diffusivities and ctrgrad ter m
+C
+c        DO i = 1, knon
+c        IF (unslev(i)) THEN
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pblk(i)/pr(i)
+c etc cf original
+c        ENDIF
+c        ENDDO
+C
+C For all layers, compute integral info and CTEI
+C
+        DO i = 1, knon
+        if (check(i).or.omegafl(i)) then
+          if (.not.Zsat(i)) then
+c            Th2 = The_th(i) - RLvCp*qT_th(i)
+            Th2 = Th_th(i)
+            T2 = Th2*s(i,k)
+c thermodyn functions
+            zdelta=MAX(0.,SIGN(1.,RTT-T2))
+            qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k)
+            qqsat=MIN(0.5,qqsat)
+            zcor=1./(1.-retv*qqsat)
+            qqsat=qqsat*zcor
+c
+            if (qqsat.lt.qT_th(i)) then
+c on calcule lcl
+              if (k.eq.2) then
+                plcl(i) = z(i,k)
+              else
+                plcl(i) =  z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .                 (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat)
+              endif
+              Zsat(i) = .true.
+              Tbef(i) = T2
+            endif
+c
+          endif
+          qsatbef(i) = qqsat
+camn ???? cette ligne a deja ete faite normalement ?
+        endif
+c            print*,'hbtm2 i,k=',i,k
+        ENDDO
+ 1000 continue           ! end of level loop
+cIM 170305 BEG
+        IF(1.EQ.0) THEN
+            print*,'hbtm2  ok'
+        ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/hgardfou.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/hgardfou.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/hgardfou.F	(revision 984)
@@ -0,0 +1,119 @@
+!
+! $Header$
+!
+      SUBROUTINE hgardfou (t,tsol,text)
+      use dimphy
+      IMPLICIT none
+c======================================================================
+c Verifier la temperature
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+      REAL t(klon,klev), tsol(klon,nbsrf)
+      CHARACTER*(*) text
+C
+      INTEGER i, k, nsrf
+      REAL zt(klon)
+      INTEGER jadrs(klon), jbad
+      LOGICAL ok
+c
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall /.TRUE./
+      IF (firstcall) THEN
+         PRINT*, 'hgardfou garantit la temperature dans [100,370] K'
+         firstcall = .FALSE.
+      ENDIF
+c
+      ok = .TRUE.
+      DO k = 1, klev
+         DO i = 1, klon
+            zt(i) = t(i,k)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+         DO i = 1, klon
+            zt(i) = tsol(i,nsrf)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      IF (.NOT. ok) THEN
+         PRINT*, 'hgardfou s arrete ', text
+         CALL abort
+      ENDIF
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/histo_o500_pctau.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/histo_o500_pctau.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/histo_o500_pctau.F	(revision 984)
@@ -0,0 +1,67 @@
+!
+! $Header$
+!
+      SUBROUTINE histo_o500_pctau(nbreg,pct_ocean,w,histo,histoW,nhisto)
+      USE dimphy
+      IMPLICIT none
+
+      INTEGER :: ij, k, l, nw
+      INTEGER :: nreg, nbreg
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      INTEGER, PARAMETER :: kmax=8, lmax=8
+      INTEGER, PARAMETER :: kmaxm1=kmax-1, lmaxm1=lmax-1
+      INTEGER, PARAMETER :: iwmax=40
+
+      INTEGER, dimension(klon) :: iw
+      REAL, dimension(klon) :: w
+      REAL, PARAMETER :: wmin=-200., pas_w=10.
+      REAL, dimension(kmaxm1,lmaxm1,iwmax,nbreg) :: histoW, nhisto
+      REAL, dimension(klon,kmaxm1,lmaxm1) :: histo
+
+!     LOGICAL, dimension(klon,nbreg) :: pct_ocean
+      INTEGER, dimension(klon,nbreg) :: pct_ocean
+
+! initialisation
+      histoW(:,:,:,:)=0.      
+      nhisto(:,:,:,:)=0.   
+!   
+!calcul de l'histogramme de chaque regime dynamique
+      DO nreg=1, nbreg
+       DO ij=1, klon
+        iw(ij) = int((w(ij)-wmin)/pas_w) +1
+c       IF(pct_ocean(ij,nreg)) THEN
+c       IF(pct_ocean(ij,nreg).EQ.1) THEN
+         IF(iw(ij).GE.1.AND.iw(ij).LE.iwmax) THEN 
+          DO l=1, lmaxm1
+           DO k=1, kmaxm1
+            IF(histo(ij,k,l).GT.0.) THEN
+             histoW(k,l,iw(ij),nreg) = histoW(k,l,iw(ij),nreg) 
+     &       + histo(ij,k,l)*pct_ocean(ij,nreg)
+             nhisto(k,l,iw(ij),nreg)= nhisto(k,l,iw(ij),nreg) + 
+     &       pct_ocean(ij,nreg)
+            ENDIF
+           ENDDO !k
+          ENDDO !l
+c        ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw
+c         PRINT*,'ij,iw=',ij,iw(ij)
+         ENDIF !iw
+c       ENDIF !pct_ocean
+       ENDDO !ij
+!normalisation
+       DO nw=1, iwmax
+        DO l=1, lmaxm1
+         DO k=1, kmaxm1
+          IF(nhisto(k,l,nw,nreg).NE.0.) THEN
+           histoW(k,l,nw,nreg) = 100.*histoW(k,l,nw,nreg)
+     &     /nhisto(k,l,nw,nreg)
+c          PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg,
+c    &     histoW(k,l,nw,nreg)
+          ENDIF
+         ENDDO !k
+        ENDDO !l
+       ENDDO !nw
+      ENDDO !nreg
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/homogene.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/homogene.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/homogene.F	(revision 984)
@@ -0,0 +1,100 @@
+!
+! $Header$
+!
+      SUBROUTINE homogene(paprs, q, dq, u,v, du, dv)
+      USE dimphy
+      IMPLICIT NONE
+c==============================================================
+c Schema ad hoc du melange vertical pour les vitesses u et v,
+c a appliquer apres le schema de convection (fiajc et fiajh).
+c
+c paprs:input, pression demi-couche (inter-couche)
+c q:    input, vapeur d'eau (kg/kg)
+c dq:   input, incrementation de vapeur d'eau (de la convection)
+c u:    input, vitesse u
+c v:    input, vitesse v
+c
+c du:   output, incrementation pour u
+c dv:   output, incrementation pour v
+c==============================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+      REAL paprs(klon,klev+1)
+      REAL q(klon,klev), dq(klon,klev)
+      REAL u(klon,klev), du(klon,klev)
+      REAL v(klon,klev), dv(klon,klev)
+c
+      REAL zm_dq(klon) ! quantite totale de l'eau deplacee
+      REAL zm_q(klon)  ! quantite totale de la vapeur d'eau
+      REAL zm_u(klon)  ! moyenne de u (brassage parfait et total)
+      REAL zm_v(klon)  ! moyenne de v (brassage parfait et total)
+      REAL z_frac(klon) ! fraction du brassage parfait et total
+      REAL zm_dp(klon)
+c
+      REAL zx
+      INTEGER i, k
+      REAL frac_max
+      PARAMETER (frac_max=0.1)
+      REAL seuil
+      PARAMETER (seuil=1.0e-10)
+      LOGICAL faisrien
+      PARAMETER (faisrien=.true.)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         du(i,k) = 0.0
+         dv(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      IF (faisrien) RETURN
+c
+      DO i = 1, klon
+         zm_dq(i)=0.
+         zm_q(i) =0.
+         zm_u(i)=0.
+         zm_v(i)=0.
+         zm_dp(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (ABS(dq(i,k)).GT.seuil) THEN
+         zx = paprs(i,k) - paprs(i,k+1)
+         zm_dq(i) = zm_dq(i) + ABS(dq(i,k))*zx
+         zm_q(i) = zm_q(i) + q(i,k)*zx
+         zm_dp(i) = zm_dp(i) + zx
+         zm_u(i) = zm_u(i) + u(i,k)*zx
+         zm_v(i) = zm_v(i) + v(i,k)*zx
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Hypothese principale: apres la convection, la vitesse de chaque
+c couche est composee de deux parties: celle (1-z_frac) de la vitesse 
+c original et celle (z_frac) de la vitesse moyenne qui serait la
+c vitesse de chaque couche si le brassage etait parfait et total.
+c La fraction du brassage est calculee par le rapport entre la quantite
+c totale de la vapeur d'eau deplacee (ou condensee) et la quantite
+c totale de la vapeur d'eau. Et cette fraction est limitee a frac_max 
+c (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995).
+c
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.0E-15 .AND. zm_q(i).GE.1.0E-15) THEN
+         z_frac(i)=MIN(frac_max,zm_dq(i)/zm_q(i))
+         zm_u(i)=zm_u(i)/zm_dp(i)
+         zm_v(i)=zm_v(i)/zm_dp(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.e-15 .AND. zm_q(i).GE.1.e-15
+     .                         .AND. ABS(dq(i,k)).GT.seuil) THEN
+         du(i,k) = u(i,k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i,k)
+         dv(i,k) = v(i,k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/hydrol.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/hydrol.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/hydrol.F	(revision 984)
@@ -0,0 +1,121 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap,
+     .                  agesno, tsol,qsol,snow,runoff)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940414
+c======================================================================
+c
+c Traitement de l'hydrologie du sol
+c ---------------------------------
+c rain_fall: taux de pluie
+c snow_fall: taux de neige
+c agesno: age de la neige
+c evap: taux d'evaporation
+c tsol: temperature du sol
+c qsol: humidite du sol
+c snow: couverture neigeuse
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c
+      REAL chasno ! epaisseur du sol: 0.15 m
+      PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15))
+      REAL mx_eau_sol
+      PARAMETER (mx_eau_sol=150.0)
+c
+      REAL dtime
+      REAL pctsrf(klon,nbsrf)
+      REAL snow(klon,nbsrf), tsol(klon,nbsrf), qsol(klon,nbsrf)
+      REAL snow_fall(klon), rain_fall(klon), evap(klon)
+      REAL runoff(klon), agesno(klon)
+C
+      INTEGER i, is
+      REAL subli, fsno
+C-----------------------------------------------------------------------
+      DO 99999 i = 1, klon
+c
+         runoff(i) = 0.0
+c
+         is = is_ter
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_lic
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+cIM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+cIM cf GK : la glace fond a 0C, non pas a -1.8
+            tsol(i,is) = MIN(tsol(i,is),RTT)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_sic
+         qsol(i,is) = 0.0
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+cIM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+cIM cf GK : la glace fond a 0C, non pas a -1.8
+            tsol(i,is) = MIN(tsol(i,is),RTT)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         agesno(i) = (agesno(i)+ (1.-agesno(i)/50.)*dtime/86400.)
+     .             * EXP(-1.*MAX(0.0,snow_fall(i))*dtime/0.3)
+         agesno(i) = MAX(agesno(i),0.0)
+c
+99999 CONTINUE
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/indicesol.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/indicesol.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/indicesol.h	(revision 984)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+!
+      INTEGER is_oce
+      PARAMETER (is_oce=3) ! ocean
+      INTEGER is_sic
+      PARAMETER (is_sic=4) ! glace de mer
+      INTEGER is_ter
+      PARAMETER (is_ter=1) ! terre
+      INTEGER is_lic
+      PARAMETER (is_lic=2) ! glacier continental
+!
+      REAL epsfra
+      PARAMETER (epsfra=1.0E-05)
+!
+      CHARACTER *3 clnsurf(nbsrf)
+      DATA clnsurf/'ter', 'lic', 'oce', 'sic'/
+      SAVE clnsurf
+!$OMP THREADPRIVATE(clnsurf)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_bilKP_ave.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_bilKP_ave.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_bilKP_ave.h	(revision 984)
@@ -0,0 +1,259 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+         zsto = dtime
+         zout = ecrit_day
+         typeval=tave
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         write(*,*)'zx_lon = ',zx_lon(:,1)
+cym         write(*,*)'zx_lat = ',zx_lat(1,:)
+cym         CALL histbeg("histbilKP_ave", iim,zx_lon(:,1), jjmp1,
+cym     .                zx_lat(1,:),
+cym     .                1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                nhori, nid_bilKPave)
+         CALL histbeg_phy("histbilKP_ave", itau_phy, zjulian, dtime,
+     .                nhori, nid_bilKPave)
+
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_bilKPave, "presnivs",
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPave,"ue",
+     .   "Zonal energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"ve",
+     .   "Merid energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"uq",
+     .   "Zonal humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vq",
+     .   "Merid humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPave,"temp",
+     .   "Air temperature","K",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"ovap",
+     .   "Specific humidity","Kg/Kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"geop",
+     .   "Geopotential height","m",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vitu",
+     .   "Zonal wind","m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"vitv",
+     .   "Meridional wind","m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "vitw", 
+     .   "Vertical wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "pres", 
+     .   "Inter-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "play", 
+     .   "Mean-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "oliq", 
+     .   "Liquid water content", 
+     .                "kg/kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtdyn", 
+     .   "Dynamics dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqdyn", 
+     .   "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtcon", 
+     .   "Convection dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "ducon", 
+     .   "Convection du", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dvcon", 
+     .   "Convection dv", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqcon",
+     .   "Convection dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlsc", 
+     .   "Condensation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqlsc",
+     .   "Condensation dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dtvdf",
+     .   "Boundary-layer dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqvdf", 
+     .   "Boundary-layer dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dtajs",
+     .   "Ajustement sec dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dqajs",
+     .   "Ajustement sec dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dteva", 
+     .   "Reevaporation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dqeva",
+     .   "Reevaporation dQ",
+     .                "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+
+c
+         CALL histdef(nid_bilKPave, "dtswr", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtsw0", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlwr", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dtlw0", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"duvdf",
+     .   "Boundary-layer dU","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave,"dvvdf",
+     .   "Boundary-layer dV","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         IF (ok_orodr) THEN
+         IF (ok_orolf) THEN
+         CALL histdef(nid_bilKPave, "duoli",
+     .   "Orography dU", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPave, "dvoli", 
+     .   "Orography dV", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF
+         ENDIF
+C
+         CALL histdef(nid_bilKPave, "duphy",
+     .   "Physiq dU","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dvphy",
+     .   "Physiq dV","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dtphy",
+     .   "Physiq dT","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dqphy",
+     .   "Physiq dQ","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPave, "dqlphy",
+     .   "Physiq dQl","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+C
+         CALL histend(nid_bilKPave)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_bilKP_ins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_bilKP_ins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_bilKP_ins.h	(revision 984)
@@ -0,0 +1,326 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+         zsto = dtime
+         zout = dtime
+         typeval=tinst
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         write(*,*)'zx_lon = ',zx_lon(:,1)
+cym         write(*,*)'zx_lat = ',zx_lat(1,:)
+c
+cIM 280405 BEG
+c
+cIM cf. AM 081204 BEG region
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+cym          do i=1,iim-1
+cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+cym          enddo
+cym          do j=1,jjmp1
+cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+cym          enddo
+c
+          print*,'On stoke le fichier bilKP instantanne sur ',
+     s   imin_ins,imax_ins,jmin_ins,jmax_ins
+          print*,'On stoke le fichier bilKP instantanne sur ',
+     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+cIM cf. AM 081204 END region
+c
+cIM 280405 END
+c
+cym         IF(1.EQ.0) THEN
+cym         CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), jjmp1,
+cym     .                zx_lat(1,:),
+cym     .                1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                nhori, nid_bilKPins)
+         ENDIF
+c
+cIM 280405 BEG
+c
+cIM cf. AM 081204 BEG region
+cym         CALL histbeg("histbilKP_ins", iim,zx_lon(:,1), 
+cym     .                 jjmp1,zx_lat(1,:),
+cym     .                 imin_ins,imax_ins-imin_ins+1,
+cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_bilKPins)
+         CALL histbeg_phy("histbilKP_ins", itau_phy, zjulian, dtime,
+     .                 nhori, nid_bilKPins)
+cIM 081204 END
+c
+cIM 280405 END
+c
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_bilKPins, "presnivs",
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPins,"ue",
+     .   "Zonal energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"ve",
+     .   "Merid energy transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"uq",
+     .   "Zonal humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vq",
+     .   "Merid humidity transport","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32, 
+     .                typeval, zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_bilKPins, "temp",
+     .   "Air temperature", "K",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"ovap",
+     .   "Specific humidity","Kg/Kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"geop",
+     .   "Geopotential height", "m",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vitu", 
+     .   "Zonal wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"vitv", 
+     .   "Meridional wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "vitw",
+     .   "Vertical wind", "m/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "pres",
+     .   "Inter-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "play",
+     .   "Mean-Layer Air pressure",
+     .                "Pa",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "oliq",
+     .   "Liquid water content", 
+     .                "kg/kg",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtdyn",
+     .   "Dynamics dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dqdyn",
+     .   "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtcon",
+     .   "Convection dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "ducon",
+     .   "Convection du", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dvcon",
+     .   "Convection dv", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqcon",
+     .   "Convection dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlsc",
+     .   "Condensation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqlsc",
+     .   "Condensation dQ","Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dtvdf",
+     .   "Boundary-layer dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dqvdf", 
+     .   "Boundary-layer dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dtajs",
+     .   "Ajustement sec dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqajs",
+     .   "Ajustement sec dQ", 
+     .               "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dteva",
+     .   "Reevaporation dT","K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dqeva",
+     .   "Reevaporation dQ",
+     .                "Kg/Kg/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+
+c
+         CALL histdef(nid_bilKPins, "dtswr", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtsw0", 
+     .   "SW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlwr", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dtlw0", 
+     .   "LW radiation dT", "K/s",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"duvdf",
+     .   "Boundary-layer dU","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins,"dvvdf",
+     .   "Boundary-layer dV","m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         IF (ok_orodr) THEN
+         IF (ok_orolf) THEN
+         CALL histdef(nid_bilKPins, "duoli", 
+     .   "Orography dU", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         CALL histdef(nid_bilKPins, "dvoli", 
+     .   "Orography dV", "m/s2",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF
+         ENDIF
+C
+         CALL histdef(nid_bilKPins, "duphy",
+     .   "Physiq dU","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dvphy",
+     .   "Physiq dV","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dtphy",
+     .   "Physiq dT","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dqphy",
+     .   "Physiq dQ","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+C
+         CALL histdef(nid_bilKPins, "dqlphy",
+     .   "Physiq dQl","-",
+     .                iim,jjphy_nb,nhori, klev,1,klev,nvert, 32,
+     .                typeval, zsto,zout)
+cIM 280405 BEG
+c
+c Champs 2D:
+c
+c u850, v850
+c        DO k=1, nlevSTD
+         DO k=1, 12
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+         IF(bb2.EQ."850") THEN 
+c
+          CALL histdef(nid_bilKPins, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jjphy_nb,nhori, 1,1,1, -99, 32,
+     .                typeval, zsto,zout)
+c
+          CALL histdef(nid_bilKPins, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jjphy_nb,nhori, 1,1,1, -99, 32,
+     .                typeval, zsto,zout)
+c
+         ENDIF !(bb2.EQ."850") 
+c
+         ENDDO !k=1, 12
+c
+cIM 280405 END
+c
+         CALL histend(nid_bilKPins)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_coord_REGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_coord_REGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_coord_REGDYN.h	(revision 984)
@@ -0,0 +1,81 @@
+c
+c $Header$
+c
+       nsrf=3
+       DO nreg=1, nbregdyn
+       DO i=1, klon
+
+c       IF (debut) THEN
+         IF(rlon(i).LT.0.) THEN
+           rlonPOS(i)=rlon(i)+360.
+         ELSE
+           rlonPOS(i)=rlon(i)  
+         ENDIF
+c       ENDIF
+
+        pct_ocean(i,nreg)=0
+
+c test si c'est 1 point d'ocean
+        IF(pctsrf(i,nsrf).EQ.1.) THEN
+
+         IF(nreg.EQ.1) THEN
+
+c TROP
+          IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+
+c PACIFIQUE NORD
+          ELSEIF(nreg.EQ.2) THEN
+           IF(rlat(i).GE.40.AND.rlat(i).LE.60.) THEN
+            IF(rlonPOS(i).GE.160..AND.rlonPOS(i).LE.235.) THEN 
+             pct_ocean(i,nreg)=1
+            ENDIF
+           ENDIF
+c CALIFORNIE ST-CU
+         ELSEIF(nreg.EQ.3) THEN
+          IF(rlonPOS(i).GE.220..AND.rlonPOS(i).LE.250.) THEN
+           IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN
+            pct_ocean(i,nreg)=1
+           ENDIF
+          ENDIF
+c HAWAI
+        ELSEIF(nreg.EQ.4) THEN 
+         IF(rlonPOS(i).GE.180..AND.rlonPOS(i).LE.220.) THEN
+          IF(rlat(i).GE.15.AND.rlat(i).LE.35.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+         ENDIF
+c WARM POOL
+        ELSEIF(nreg.EQ.5) THEN 
+         IF(rlonPOS(i).GE.70..AND.rlonPOS(i).LE.150.) THEN
+          IF(rlat(i).GE.-5.AND.rlat(i).LE.20.) THEN
+           pct_ocean(i,nreg)=1
+          ENDIF
+         ENDIF
+        ENDIF !nbregdyn
+c TROP
+c        IF(rlat(i).GE.-30.AND.rlat(i).LE.30.) THEN
+c         pct_ocean(i)=.TRUE.
+c         WRITE(*,*) 'pct_ocean =',i, rlon(i), rlat(i)
+c          ENDIF !lon
+c         ENDIF !lat
+
+        ENDIF !pctsrf
+       ENDDO !klon
+       ENDDO !nbregdyn
+cIM 190504      ENDIF !ok_regdyn
+ 
+cIM somme de toutes les nhistoW BEG
+      IF (debut) THEN
+      DO nreg = 1, nbregdyn
+       DO k = 1, kmaxm1
+        DO l = 1, lmaxm1
+         DO iw = 1, iwmax
+          nhistoWt(k,l,iw,nreg)=0.
+         ENDDO !iw
+        ENDDO !l
+       ENDDO !k
+      ENDDO !nreg
+      ENDIF !(debut) THEN
+cIM 190504 BEG
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histISCCP.h	(revision 984)
@@ -0,0 +1,267 @@
+!
+! $Header$
+!
+      IF (ok_isccp) THEN
+c
+c$OMP MASTER
+      ndex2d = 0
+      ndex3d = 0
+c
+c pour les champs instantannes, il faut mettre la meme valeur pour
+c zout et zsto.
+c dtime est passe par ailleurs a histbeg
+c zstophy = frequence de stockage des champs tous les pdt physiques
+c zout = frequence d'ecriture des champs
+cIM 300505     zstophy = dtime 
+c appel du simulateur toutes les 3heures
+!IM on lit la frequence d'appel dans physiq.def
+!         zcals(1) = dtime *6.  !toutes les 3h (en s)
+          zcals(1) = freq_ISCCP !toutes les freq_ISCCP secondes
+        DO n=1, napisccp
+          zcalh(n) = zcals(n)/3600. !stoutes les Xh (en heures)
+        ENDDO !n
+c
+c ecriture 8 fois par jour
+c       zout = dtime * REAL(NINT(86400./dtime*ecrit_isccp))
+c ecriture toutes les 2h (12 fois par jour)
+c       zout = dtime * 4.
+c ecriture toutes les 1/2 h (48 fois par jour)
+c       zout = dtime
+c
+c       IF(freqout_isccp.EQ.1.) THEN
+c ecriture jounaliere
+!IM on ecrit les resultats du simulateur ISCCP toutes les 
+! ecrit_ISCCP secondes      zout_isccp(1) = ecrit_day !(en s)
+          zout_isccp(1) = ecrit_ISCCP !(en s)
+c ecriture mensuelle
+c         zout = dtime * ecrit_mth !(en s)
+        DO n=1, napisccp 
+          zoutj(n)=zout_isccp(n)/86400. !(en jours)
+c
+c le nombre de sous-colonnes ncol : ncol=(100.*zcalh)/zoutd
+          ncol(n)=NINT((100.*zcalh(n))/zoutj(n))
+          IF(ncol(n).GT.ncolmx) THEN
+           PRINT*,'Warning: Augmenter le nombre colonnes du simulateur'
+           PRINT*,'         ISCCP ncol=', ncol,' ncolmx=',ncolmx
+c          PRINT*,'n ncol',n,ncol(n)
+           CALL abort
+          ENDIF
+c
+        DO l=1, ncol(n)
+          vertlev(l,n)=float(l)
+        ENDDO !ncol
+c
+        ENDDO !n
+
+c       PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp
+c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c       write(*,*)'ISCCP ', itau_phy, zjulian
+c
+c
+c definition coordonnees lon,lat en globale
+c
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym        DO i = 1, iim
+cym          zx_lon(i,1) = rlon(i+1)
+cym          zx_lon(i,jjmp1) = rlon(i+1)
+cym        ENDDO
+
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+cIM BEG region
+cym Desole dans un premier temps le mode region ne marchera pas
+cym Il faudra voir dans un second temps pour l'implementer
+cym Mais cela posera des problemes au niveau de la reconstruction
+
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+cym          do i=1,iim-1
+cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+cym          enddo
+cym          do j=1,jjmp1
+cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+cym          enddo
+c
+          print*,'On stoke le fichier histISCCP sur ',
+     s   imin_ins,imax_ins,jmin_ins,jmax_ins
+cym          print*,'On stoke le fichier histISCCP instantanne sur ',
+cym     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+cym     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+cIM END region
+c
+        IF(1.EQ.0) THEN
+cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:),
+cym     .                 1, iim, 1, jjmp1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_isccp)
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,
+     .                 nhori, nid_isccp)
+        ENDIF !(1.EQ.0) THEN
+c
+cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),
+cym     .                 jjmp1,zx_lat(1,:),
+cym     .                 imin_ins,imax_ins-imin_ins+1,
+cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+cym     .                 itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_isccp)
+
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,
+     .                 nhori, nid_isccp)
+c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+         CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb",
+     .                 lmaxm1, cldtopres, nvert,'down')
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+         CALL histvert(nid_isccp,"cldtopres3","Cloud Top Pressure","mb",
+     .                 lmax3, cldtopres3, nvert3,'down')
+        ENDIF
+        DO n=1, napisccp
+         CALL histvert(nid_isccp, "Nbcol"//verticaxe(n),
+     .        "Nb of Column"//verticaxe(n),"1",
+     .        ncol(n), vertlev(:,n), nvlev(n),'up')
+        ENDDO
+c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+c variables a ecrire
+c 
+         DO n=1, napisccp
+c
+         DO k=1, kmaxm1
+          CALL histdef(nid_isccp, "cldISCCP_"//taulev(k)//verticaxe(n),
+     .                "LMDZ ISCCP cld", "%",
+     .                iim, jj_nb,nhori,lmaxm1,1,lmaxm1,nvert,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+         ENDDO
+c
+         CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),
+     .                "Nb of calls with sunlit ", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+         ENDDO
+c
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+         DO n=1, napisccp
+c
+c         print*,'n=',n,' avant histdef(..LMDZ ISCCP cld'
+c
+          DO k=1, kmaxm1
+           DO l=1, lmaxm1
+c
+           CALL histdef(nid_isccp, pclev(l)//taulev(k)//verticaxe(n),
+     .                "LMDZ ISCCP cld "//cnameisccp(l,k), "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+           ENDDO
+          ENDDO
+c
+c         print*,'n=',n,' avant histdef(..Nb of calls sunlit'
+          CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),
+     .                "Nb of calls with sunlit ", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c 9types de nuages ISCCP-D2
+          CALL histdef(nid_isccp, "cirr",
+     .                "Cirrus lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "cist",
+     .                "CiSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "deep",
+     .                "Deep lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "alcu",
+     .                "AlCu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "alst",
+     .                "AlSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "nist",
+     .                "NiSt lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "cumu",
+     .                "Cumu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "stcu",
+     .                "StCu lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "stra",
+     .                "Stra lk ISCCP-D2", "%",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c 3_epaisseurs_optiques x3_pressions_au_sommet_des_nuages  types de nuages 
+          CALL histdef(nid_isccp, "thin",
+     .                "Opt. thin ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "mid",
+     .                "Opt. intermediate ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+          CALL histdef(nid_isccp, "thick",
+     .                "Opt. thick ISCCP-D2 like clouds", "%",
+     .                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+c        IF(1.EQ.0) THEN
+c        IF(n.EQ.3) THEN
+c        IF(n.EQ.1) THEN
+c
+cIM 070905 BEG
+         IF(1.EQ.0) THEN
+          print*,'n=',n,' avant histdef(..boxptop axe'
+cIM verif boxptop
+          CALL histdef(nid_isccp,"boxptop"//verticaxe(n),
+     .                "Boxptop axe"//verticaxe(n), "mb",
+     .                iim, jj_nb,nhori,
+     .                ncol(n),1,ncol(n),nvlev(n),32,
+cIM  .                ncolmx,1,ncolmx,nvlev,32,
+cIM  .                "inst(X)",dtime,dtime)
+     .                "ave(X)",zcals(n),zout_isccp(n))
+         ENDIF !(1.EQ.0) THEN
+cIM 070905 END
+c        ENDIF !(n.EQ.3) THEN
+c       ENDIF !(1.EQ.0) THEN
+c
+c         print*,'n=',n,' avant histdef(..seed axe'
+          CALL histdef(nid_isccp, "seed"//verticaxe(n),
+     .                "seed axe"//verticaxe(n), "-",
+     .                iim, jj_nb,nhori,1,1,1,-99,32,
+cIM  .                "inst(X)", dtime,dtime)
+     .                "ave(X)", zcals(n),zout_isccp(n))
+c
+         ENDDO !n
+        ENDIF 
+        CALL histend(nid_isccp)
+c
+c$OMP END MASTER
+      ENDIF ! ok_isccp
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histREGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histREGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histREGDYN.h	(revision 984)
@@ -0,0 +1,127 @@
+!
+! $Header$
+!
+
+      IF (ok_regdyn) THEN
+      
+        if (is_sequential) then
+c
+cIM      PRINT*, 'La frequence de sortie REGDYN est de ', ecrit_mth
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+c axe vertical pour les differents niveaux des histogrammes
+      DO iw=1, iwmax
+        zx_o500(iw)=wmin+(iw-1./2.)*pas_w
+      ENDDO
+
+         CALL histbeg("histREGDYN", kmaxm1,zx_tau, lmaxm1,zx_pc,
+     .                 1,kmaxm1,1,lmaxm1, itau_phy, zjulian, dtime, 
+     .                 nhoriRD, nid_regdyn)
+
+         CALL histvert(nid_regdyn, "omeganivs", "Omega levels", 
+     .                 "mb/day",
+     .                 iwmax, zx_o500, komega)
+c
+c   pour les champs instantannes, il faut mettre la meme valeur pour
+c   zout et zsto.
+c   dtime est passe par ailleurs a histbeg
+c
+c        zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn))
+c        zsto = zout
+c        print*,'zout,zsto=',zout,zsto
+c
+c stockage a chaque pas de temps de la physique
+c
+         zstophy = dtime
+cIM 020904      zstophy = dtime * nbapp_isccp
+
+c ecriture mensuelle
+c
+         zout = dtime * ecrit_mth
+cIM 020904      
+c        zout = dtime * ecrit_day
+c        zout = dtime * REAL(NINT(86400./dtime*ecrit_regdyn))
+
+c
+c Champs 3D:
+c
+c TROP
+         CALL histdef(nid_regdyn, "hw1", "Tropics Histogram ", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh1", "Nb of pixels Tropics Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht1",
+     &                "Total Nb pixels Tropics Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+c PAN
+         CALL histdef(nid_regdyn, "hw2", "North Pacific Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh2", "Nb of pixels North Pacific",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht2",
+     &                "Total Nb pixels North Pacific Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c CAL
+         CALL histdef(nid_regdyn, "hw3", "California Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh3", 
+     &                "Nb of pixels California Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht3",
+     &                "Total Nb pixels California Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c HAW
+         CALL histdef(nid_regdyn, "hw4", "Hawai Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh4", "Nb of pixels Hawai Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht4",
+     &                "Total Nb pixels Hawai Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c WAP
+         CALL histdef(nid_regdyn, "hw5", "Warm Pool Histogram", "%",
+     &                kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega, 32, 
+     &                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_regdyn, "nh5", "Nb of pixels Warm Pool Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+
+         CALL histdef(nid_regdyn, "nht5",
+     &                "Total Nb pixels Warm Pool Histo",
+     &                "%",kmaxm1,lmaxm1,nhoriRD, iwmax,1,iwmax, komega,
+     &                32,"ave(X)", zstophy,zout)
+c
+         CALL histend(nid_regdyn)
+	 
+	 endif ! is_sequential
+
+      endif ! ok_regdyn
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histday.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histday.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histday.h	(revision 984)
@@ -0,0 +1,674 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+
+c$OMP MASTER
+c
+       zstophy = dtime
+       zstoday= ecrit_day
+       zout = ecrit_day
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_day)
+
+         CALL histbeg_phy("histday",itau_phy, zjulian, dtime, 
+     .                    nhori, nid_day)
+
+         write(*,*)'Journee ', itau_phy, zjulian
+         CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+       IF(lev_histday.GE.1) THEN
+c
+         CALL histdef(nid_day, "phis", "Surface geop. height", "m2/s2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "contfracATM","% sfce ter+lic ","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+         CALL histdef(nid_day, "contfracOR","% sfce terre OR", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_day, "weakinv", "Weak inversion", "",
+     s           iim,jjmp1,nhori, 1,1,1, -99, 32,
+     s           "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "dthmin", "dTheta mini", "K/m",
+     s           iim,jjmp1,nhori, 1,1,1, -99, 32,
+     s           "ave(X)", zstophy,zout)
+
+
+         CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c Champs retires momentannement en attendant un hypothetique
+c debugage
+
+         CALL histdef(nid_day, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_day, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "plul", "Large-scale Precip.",
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "pluc", "Convective Precip.",
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "snowl", "Solid Large-scale Precip.",
+     .   "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF(1.EQ.0) THEN !snowc=0.
+         CALL histdef(nid_day, "snowc", "Solid Convective Precip.",
+     .   "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF !snowc=0.
+c
+         CALL histdef(nid_day, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstoday,zout)
+c
+         CALL histdef(nid_day, "q2m", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "wind10max", "10-m wind speed max.",
+     .                "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "precip","Precipitation Totale liq+sol"
+     .                , "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "snowf", "Snow fall", "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_day, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "evap", "Evaporation", "kg/(m2*s)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sols", "Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cldq", "Cloud liquid water path", 
+     .                "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c  Champs dynamiques sur niveaux de pression
+c
+c        DO k=1, nlevENS
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb2=clevSTD(k)
+c        ENDIF
+c
+         IF(bb2.EQ."850".OR.bb2.EQ."700"
+     .   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_day, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_day, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+         IF(bb2.EQ."500") THEN
+c
+         CALL histdef(nid_day, "w"//bb2, "Vertical wind "//bb2//"mb",
+     .                "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_day,"phi"//bb2, "Geopotential "//bb2//"mb",
+     .                "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."500")
+c
+         ENDDO !nlevSTD
+c
+         CALL histdef(nid_day, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "cape_max", "CAPE max.",
+     .                "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                capemaxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+         IF (OCEAN.EQ.'force ') THEN
+c
+          CALL histdef(nid_day, "lmt_bils", 
+     .         "Bilan au sol atmosphere forcee", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+          CALL histdef(nid_day, "slab_bils",
+     .                "Bilan au sol slab", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "tslab", "Slab SST ", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "seaice", "Slab seaice", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_day, "siceh", "Slab seaice height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF !OCEAN.EQ.force/slab
+c
+         CALL histdef(nid_day, "fluxo",
+     .                "Flux turbulents ocean-atmosphere", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "fluxg",
+     .                "Flux ocean-glace de mer", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.1
+c
+      IF (lev_histday.GE.2) THEN
+c
+         CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2/K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.2
+c=================================================================
+      IF(lev_histday.GE.3) THEN
+c=================================================================
+c   INITIALISATION DES CHAMPS 3D
+c=================================================================
+c=================================================================
+c=================================================================
+c Champs 3D:
+c
+         CALL histdef(nid_day, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c=================================================================
+c   FIN INITIALISATION DES CHAMPS 3D
+c=================================================================
+      ENDIF !  lev_histday.GE.3
+c
+      IF (lev_histday.GE.4) THEN
+c=================================================================
+c
+c   INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+c
+         CALL histdef(nid_day, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "SWupTOAclr",
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWupSFCclr",
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWdnTOAclr",
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_day, "SWdnSFCclr",
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM AMMA-MIP
+         CALL histdef(nid_day, "LWdnSFC",
+     .                "LW down at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "LWupSFC",
+     .                "LW down at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+cIM     IF (iflag_con.GE.3) THEN 
+         CALL histdef(nid_day, "ptop",
+c    .                "Cld top pressure","mb",
+     .                "Cld top pressure (cf ISCCP simulator)","Pa",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+cIM     ENDIF !(iflag_con.GE.3) THEN 
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c   INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c=================================================================
+c
+         CALL histdef(nid_day, "tter", "Surface Temperature ter", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tlic", "Surface Temperature lic", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "toce", "Surface Temperature oce", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tsic", "Surface Temperature sic", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter", "Temp.tere 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mlic", "Temp.lic 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2moce", "Temp.oce 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2msic", "Temp.sic 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter_min", "Temp.terre 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_day, "t2mter_max", "Temp.terre 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+         CALL histdef(nid_day, "u10mter", "Vent zonal ter 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10mlic", "Vent zonal lic 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10moce", "Vent zonal oce 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "u10msic", "Vent zonal sic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10mter", "Vent meridien ter 10m", 
+     .                "m/s", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10mlic", "Vent meridien lic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10moce", "Vent meridien oce 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "v10msic", "Vent meridien sic 10m",
+     .                 "m/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_day, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_day, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress "//clnsurf(nsrf),"Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_day, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_day, "rugs_"//clnsurf(nsrf), 
+     $         "Rugosite "//clnsurf(nsrf), "m",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+
+
+! FH Sorties specifiques pour Mellor et Yamada
+      if (iflag_pbl>1 .and. lev_histday.gt.10 ) then
+           call histdef(nid_day, "tke_"//clnsurf(nsrf), 
+     $         "Max Turb. Kinetic Energy "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_day, "tke_max_"//clnsurf(nsrf), 
+     $         "Max Turb. Kinetic Energy "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     $         "t_max(X)", zstophy,zout)
+      endif	
+
+C
+         END DO 
+C           
+c=================================================================
+c
+c   FIN INITIALISATION DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+      ENDIF !lev_histday.GE.4
+c
+      IF(lev_histday.GE.5) THEN !lev_histday.GE.5
+c
+c rajout sorties F. Aires
+         CALL histdef(nid_day, "tops0", "CS Solar rad. at TOA", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "topl0", "CS IR rad. at TOA", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "sols0", "CS Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "soll0", "CS Net IR rad. at surface", 
+     .                "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rneb", "Cloud fraction", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"meantaucld",
+     .                "ISCCP mean cloud optical thickness","1",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"cldtau","Cloud optical thickness","1",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_day,"cldemi","Cloud optical emissivity","1",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM rajout AMMA-MIP
+c
+         CALL histdef(nid_day, "dtcon", "Convection dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "dqcon", "Convection dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "rh2m", "Relative humidity at 2m", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "qsat2m", "Saturant humidity at 2m", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tpot", 
+     .                "Surface air potential temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day, "tpote", 
+     .        "Surface air equivalent potential temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histday.GE.5
+c=================================================================
+c
+         CALL histend(nid_day)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c=================================================================
+c$OMP END MASTER
+      ENDIF ! fin de test sur ok_journe
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histday_seri.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histday_seri.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histday_seri.h	(revision 984)
@@ -0,0 +1,131 @@
+c
+c $Header$
+c
+cym Ne fonctionnera pas en mode parallele
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+c
+       zstophy = dtime
+       zout = ecrit_day
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+         imin_debut=1 
+         nbpti=1
+         jmin_debut=1 
+         nbptj=1
+c
+         CALL histbeg("histday_seri.nc", 
+     .                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 imin_debut,nbpti,jmin_debut,nbptj,
+     .                 itau_phy, zjulian, dtime,
+     .                 nhori, nid_day_seri)
+c
+         CALL histvert(nid_day_seri, "presnivs", 
+     .                "Vertical levels","mb",
+     .                 klev, presnivs/100., nvert)
+c
+         CALL histdef(nid_day_seri, "bilTOA", 
+     .                "Net radiation at model top", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "bils", 
+     .                "Net downward energy flux at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "ecin", 
+     .                "Total kinetic energy (per unit area)","J/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM 151004 BEG
+         IF(1.EQ.0) THEN
+c
+         CALL histdef(nid_day_seri, "momang", 
+     .               "Total relative angular momentum (per unit area)",
+     .               "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "frictor", 
+     .               "Friction torque (per unit area)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "mountor", 
+     .               "Mountain torque (per unit area)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF !(1.EQ.0) THEN
+c
+         CALL histdef(nid_day_seri, "momang", 
+     .               "Axial angular momentum (per unit area)",
+     .               "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "torsfc", 
+     .        "Total surface torque (including mountain torque)", "N/m",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM 151004 END        
+c
+         CALL histdef(nid_day_seri, "tamv", 
+     .                "Temperature (mass-weighted vert. ave)", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "psol", 
+     .                "Surface pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_day_seri, "evap", 
+     .                "Evaporation and sublimation (per unit area)", 
+     .                "kg/(m2*s)",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          call histdef(nid_day_seri, 
+c    .         "SnowFrac", 
+c    .         "Snow-covered area ", "%",  
+c    .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_day_seri, "snow_depth", 
+cIM 080904  .                "Snow Depth (water equivalent)", "m",
+cIM 191104  .                "Snow Depth (water equivalent)", "kg/m2",
+c    .                "Snow Mass", "kg/m2",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .               "ave(X)", zstophy,zout)
+c
+           call histdef(nid_day_seri, 
+     .         "tsol_"//clnsurf(is_oce), 
+     .         "SST over open (ice-free) ocean ", "K",  
+     .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+c=================================================================
+c
+         CALL histend(nid_day_seri)
+c
+c=================================================================
+      ENDIF ! fin de test sur type_run.EQ.AMIP
+      
+      ENDIF ! is_sequential
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histhf.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histhf.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histhf.h	(revision 984)
@@ -0,0 +1,402 @@
+!
+! $Header$
+!
+
+      IF (ok_hf) THEN
+c$OMP MASTER
+c
+       zstohf = ecrit_hf
+       zstophy = dtime
+       zstoday = ecrit_day
+       zout = ecrit_hf
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+cym         CALL histbeg("histhf", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_hf)
+
+         CALL histbeg_phy("histhf", itau_phy, zjulian, dtime, 
+     .                 nhori, nid_hf)
+
+         CALL histvert(nid_hf, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+         CALL histdef(nid_hf, "aireTER","Grid area CONT","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+         CALL histdef(nid_hf, "contfracATM","% sfce ter+lic ","-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+         CALL histdef(nid_hf, "contfracOR","% sfce terre OR", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zstohf,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_hf, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "precip", "Precipitation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+cIM ENSEMBLES BEG
+         CALL histdef(nid_hf, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         CALL histdef(nid_hf, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+          IF(bb2.EQ."500") THEN
+          CALL histdef(nid_hf, "phi"//bb2,
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+          ENDIF !bb2.EQ."500"
+         ENDDO !k=1, nlevSTD
+c
+      ENDIF !lev_histhf.GE.1
+c
+      IF(lev_histhf.GE.2) THEN
+c
+         CALL histdef(nid_hf, "cldt", "Total cloudiness", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "SWnetOR",
+     .                "Sfce net SW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "SWdownOR",
+     .                "Sfce incident SW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_hf, "LWdownOR",
+     .                "Sfce incident LW radiation OR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+      ENDIF !lev_histhf.GE.2
+c
+cIM ENSEMBLES END
+c
+      IF(lev_histhf.GE.3) THEN
+c
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".or.bb2.EQ."700".OR.
+     $      bb2.EQ."500".or.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_hf, "t"//bb2,
+     .                 "Temperature "//bb2//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          IF(bb2.NE."500") THEN
+          CALL histdef(nid_hf, "phi"//bb2, 
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+          ENDIF
+c
+          CALL histdef(nid_hf, "q"//bb2,
+     .                 "Specific humidity "//bb2//"mb","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          CALL histdef(nid_hf, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+          CALL histdef(nid_hf, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zout)
+c
+         ENDIF !IF(bb2.EQ."850".or.bb2.EQ."700".OR.
+c
+         ENDDO !nlevSTD
+c
+      ENDIF !lev_histhf.GE.3
+c
+      IF(lev_histhf.GE.4) THEN
+c
+cIM sorties hf 3D
+c
+#undef histhf3d
+#define histhf3d
+#ifdef histhf3d
+#include "ini_histhf3d.h"
+#endif
+      ENDIF !lev_histhf.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+        DO k=1, nlevSTD 
+c
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".or.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_hf, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb2.EQ."850".or.bb2.EQ."200"
+        ENDDO !k=1, nlevSTD
+c
+        CALL histdef(nid_hf, "topl", 
+     .       "Outgoing longwave radiation", "W/m2",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "precip","Total precipitation rate",
+     .       "kg/(s*m2)",iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .       "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "slp", 
+     .       "Mean sea-level pressure", "Pa",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "inst(X)", zstohf,zout)
+c
+cIM 280504 BEG
+      ENDIF !(lev_histhf.GE.1) THEN
+c
+      IF(lev_histhf.GE.2) THEN
+c
+        DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+         IF(bb2.EQ."850".OR.bb2.EQ."500") THEN
+c
+          CALL histdef(nid_hf, "t"//bb2,
+     .                 "Temperature "//bb2//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "q"//bb2,
+     .                 "Specific humidity "//bb2//"mb","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb2
+c
+         IF(bb2.EQ."500") THEN
+c
+          CALL histdef(nid_hf, "phi"//bb2,
+     .                "Geopotential "//bb2//"mb", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "w"//bb2,
+     .                 "Vertical motion "//bb2//"mb","Pa/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+         ENDIF !bb2.EQ."500"
+c
+         IF(bb3.EQ."50") THEN
+c
+          CALL histdef(nid_hf, "t"//bb3,
+     .                 "Temperature "//bb3//"mb","K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "u"//bb3,
+     .                 "Zonal wind "//bb3//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+          CALL histdef(nid_hf, "v"//bb3,
+     .                 "Meridional wind "//bb3//"mb","m/s",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "inst(X)", zstohf,zstohf)
+c
+         ENDIF !bb3
+c
+        ENDDO !k=1, nlevSTD
+c
+        CALL histdef(nid_hf, "u10m", "Vent zonal 10m", "m/s",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "v10m", "Vent meridien 10m", "m/s",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "t2m", "Temperature 2m", "K",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "q2m", "Specific humidity", "kg/kg",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .               "inst(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "cldt", "Total cloudiness", "%",
+     .               iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .               "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "taux",
+     $         "Zonal wind stress","Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "tauy",
+     $         "Meridional wind stress ", "Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+cIM 090904  .                "ave(X)", zstohf,zout)
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+cIM 090904  .                "ave(X)", zstohf,zout)
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_hf, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+c       CALL histdef(nid_hf, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf,"LWdnSFC","Down. IR rad. at surface",
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf,"LWupSFC","Upwd. IR rad. at surface",
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstohf,zout)
+c
+        DO k=1, nbteta
+         CALL histdef(nid_hf, "PV"//ctetaSTD(k),
+     $               "Vorticite potentielle "//ctetaSTD(k)//"K",
+     $               "1/(Pa*s)",iim,jj_nb,nhori, 1,1,1, -99,
+     $                 32, "inst(X)", zstohf,zout) 
+        ENDDO !k=1, nbteta
+c
+c planetary boundary layer height
+c
+c       ENDIF !1.EQ.0
+c
+      ENDIF !(lev_histhf.GE.2) THEN
+cIM 280504 END
+c
+      ENDIF !type_run
+c
+      CALL histend(nid_hf)
+c
+c$OMP END MASTER
+      ENDIF ! ok_hf
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histhf3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histhf3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histhf3d.h	(revision 984)
@@ -0,0 +1,51 @@
+c $Header$
+c
+c sorties hf 3d
+c
+        zstohf = ecrit_hf
+        zout = ecrit_hf
+c
+c       PRINT*, 'La frequence de sortie hf3d est de ', ecrit_hf
+c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+cym         CALL histbeg("histhf3d", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_hf3d)
+         CALL histbeg_phy("histhf3d", itau_phy, zjulian, dtime, 
+     .                 nhori, nid_hf3d)
+
+        CALL histvert(nid_hf3d, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+c Champs 3D:
+c
+        CALL histdef(nid_hf3d, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histdef(nid_hf3d, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstohf,zout)
+c
+        CALL histend(nid_hf3d)
+c
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histins.h	(revision 984)
@@ -0,0 +1,292 @@
+!
+! $Header$
+!
+      IF (ok_instan) THEN
+c$OMP MASTER
+c
+          zsto = ecrit_ins
+          zout = ecrit_ins
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+cym     .                 nhori, nid_ins)
+         CALL histbeg_phy("histins", itau_phy, zjulian, dtime,
+     .                 nhori, nid_ins)
+         write(*,*)'Inst ', itau_phy, zjulian
+         CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
+cIM    .                 klev, presnivs, nvert)
+     .                 klev, presnivs/100., nvert)
+c        call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
+c    .              klev, znivsig, nvert)
+c
+c
+         CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_ins, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+        CALL histdef(nid_ins, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "q2m", "Specific humidity 2m", "Kg/Kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+        CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c        CALL histdef(nid_ins, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "topl", "OLR", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "evap", "Evaporation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_ins, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "tsol_"//clnsurf(nsrf), 
+     $         "Surface Temperature"//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+C
+           call histdef(nid_ins, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf),"Pa",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional xind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "albe_"//clnsurf(nsrf), 
+     $         "Albedo "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "rugs_"//clnsurf(nsrf), 
+     $         "rugosite "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+CXXX
+         END DO 
+         CALL histdef(nid_ins, "rugs", "rugosity", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+c
+         CALL histdef(nid_ins, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+         CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c
+cIM cf. AM 081204 BEG
+c HBTM2
+         CALL histdef(nid_ins, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_pblt", "T at Boundary Layer Height", 
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_capCL", "Conv avlbl pot ener for 
+     .                ABL", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_cteiCL", "Instability criteria 
+     .                (ABL)", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs 3D:
+c
+         CALL histdef(nid_ins, "temp", "Temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "geop", "Geopotential height", "m",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+
+         CALL histend(nid_ins)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c$OMP END MASTER
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histmth.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histmth.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histmth.h	(revision 984)
@@ -0,0 +1,1913 @@
+c
+c $Header$
+c
+      IF (ok_mensuel) THEN
+c$OMP MASTER
+c
+       zstophy = dtime
+       zstomth = ecrit_mth                       !valeurs mensuelles "instantannees"
+       zstorad = dtime * FLOAT(radpas)    !variables stockees toutes les 2h
+       zstohf = ecrit_hf                         !variables stockees toutes les 6h
+       zout = ecrit_mth                          !frequence des sorties : 1 val. par mois
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_mth)
+
+           CALL histbeg_phy("histmth",itau_phy, zjulian, dtime, 
+     .                 nhori, nid_mth)
+     
+       write(*,*)'Mensuel ', itau_phy, zjulian
+         CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs/100., nvert)
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+         CALL histdef(nid_mth, "phis", 
+     .                "Surface geop. height", "m2/s2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_ter), 
+     .         "% "//clnsurf(is_ter), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_ter), 
+     .         "Fraction "//clnsurf(is_ter), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c ENSEMBLES BEG
+         CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c ENSEMBLES END
+         CALL histdef(nid_mth, "q2m", "Specific humidity 2m", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "qsurf", "Surface Air humidity", "kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      if (.not. ok_veget) then
+         CALL histdef(nid_mth, "qsol", "Soil watter content", "mm",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "ndayrain", 
+     .                "Number of day with rain (liq+sol)", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstomth,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "snow", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "evap", "Evaporation", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops0", "CS Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOAclr", 
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOAclr", 
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200", "SWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200clr", 
+     .                "SWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200", "SWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200clr", 
+     .                "SWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200", "LWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200clr", 
+     .                "LWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200", "LWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200clr", 
+     .                "LWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFCclr", 
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFCclr", 
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFCclr",
+     .                "CS Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFCclr",
+     .                "Down. CS IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting",
+     .                "W/m2",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqcalving","Ice Calving",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqfonte","Land ice melt",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+
+         DO nsrf = 1, nbsrf
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+         ENDDO
+c
+         DO nsrf = 1, nbsrf
+C
+          IF(nsrf.GT.2) THEN
+           call histdef(nid_mth, "pourc_"//clnsurf(nsrf), 
+     $         "% "//clnsurf(nsrf), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fract_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+          ENDIF !nsrf.GT.2
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "flw_"//clnsurf(nsrf),
+     $         "LW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fsw_"//clnsurf(nsrf),
+     $         "SW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbils_"//clnsurf(nsrf),
+     $         "Bilan sol "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbilo_"//clnsurf(nsrf),
+     $         "Bilan eau "//clnsurf(nsrf), "kg/(m2*s)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+cIM 250105 BEG
+          IF(1.EQ.0) THEN
+C
+           call histdef(nid_mth, "evapour_"//clnsurf(nsrf),
+     $         "Evap*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "prepour_"//clnsurf(nsrf),
+     $         "Precip*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+          ENDIF !(1.EQ.0) THEN
+cIM 250105 END
+C
+         END DO
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cKE43
+      IF(iflag_con.GE.3) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !iflag_con .GE. 3
+c34EK
+cIM cf. AM 081204 BEG
+c34EK
+c HBTM2
+         CALL histdef(nid_mth, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_pblt", "t at Boundary Layer Height",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_capCL", "Conv avlbl pot ener 
+     .                for ABL", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_cteiCL", "Instability criteria 
+     .                (ABL)", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs interpolles sur des niveaux de pression
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_mth, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "w"//bb2,
+     .                 "Vertical wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "phi"//bb2,
+     .                 "Geopotential "//bb2//"mb","m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+        ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+       ENDDO
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+       CALL histdef(nid_mth, "fluxo",
+     .              "Flux turbulents ocean-atmosphere", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "fluxg",
+     .              "Flux turbulents ocean-glace de mer","W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "t_oce_sic",
+     .              "Temp. mixte oce-sic","K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       IF (OCEAN.EQ.'force ') THEN
+c
+        CALL histdef(nid_mth, "lmt_bils",
+     .       "Bilan au sol atmosphere forcee", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+        CALL histdef(nid_mth, "slab_bils",
+     .       "Bilan au sol Slab", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "tslab", "Slab SST ", "K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "seaice", "Slab seaice", "kg/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "siceh", "Slab seaice height", "m",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ENDIF
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+c
+c
+         CALL histdef(nid_mth,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "ppmv",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqphy", "Physics dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+        DO nsrf=1, nbsrf
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+	 ENDDO !nsrf=1, nbsrf
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.3
+c
+      IF(lev_histmth.GE.4) THEN
+c
+!FH Sorties pour la couche limite
+      if (iflag_pbl>1) then
+         CALL histdef(nid_mth, "tke","TKE","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tke_max","TKE max","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "kz","Kz melange","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "kz_max","Kz melange max","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+
+
+         CALL histdef(nid_mth, "clwcon", 
+     .                "Convective Cloud Liquid water content"
+     .                , "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+
+
+c
+c        CALL histdef(nid_mth, "ducon", "Convection du", "m/s2",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqcon", "Convection dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlschr",
+     $     "Large-scale condensational heating rate", "K/s",iim,jj_nb
+     $     ,nhori, klev,1,klev,nvert, 32,"ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqvdf","Boundary-layer dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqeva","Reevaporation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "dtthe", "Dry adjust. dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth,"dqthe","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth,"dqajs","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+         CALL histdef(nid_mth, "tau", "cloud opt thickness", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM1", "CCM1", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM2", "CCM2", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "cldemi", "emissivite IR", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_NAT", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AD", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AI", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AD", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_NAT", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+#endif
+#ifndef INCA
+         if (nqmax.GE.3) THEN
+           DO iq=3,nqmax
+             iiq=niadv(iq)
+             CALL histdef(nid_mth, tnom(iq), ttext(iiq), "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+             ENDDO
+           ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+         CALL histdef(nid_mth, "phis", "Surface geop. height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "once",  zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_ter), 
+     .         "% "//clnsurf(is_ter), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_ter), 
+     .         "Fraction "//clnsurf(is_ter), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_lic), 
+     .         "% "//clnsurf(is_lic), "%",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_lic), 
+     .         "Fraction "//clnsurf(is_lic), "1",  
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "once", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pourc_"//clnsurf(is_sic),
+     .         "% "//clnsurf(is_sic), "%",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fract_"//clnsurf(is_sic),
+     .         "Fraction "//clnsurf(is_sic), "1",
+     .         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "flat", "Latent heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bilTOA",
+     .                "Net radiation at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c
+c        CALL histdef(nid_mth, "tops01",
+c    .                "TOA reflected clear-sky shortwave 
+c    .                radiation (method 1)", "W/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtdia","dtdia","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtsw","dtsw","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtlw","dtlw","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtcon","dtcon","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtthe", "Dry adjust. dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth,"dqthe","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtajs","dtajs","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dtlsc","dtlsc","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dqdia","dqdia","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "duoli",
+     .         "duoli","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvoli",
+     .         "dvoli","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "ducon",
+     .         "ducon","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvcon",
+     .         "dvcon","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dutot",
+     .         "dutot","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "dvtot",
+     .         "dvtot","m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c         CALL histdef(nid_mth, "cldtrue",
+c    .         "TRUE Cloud fraction ","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "inst(X)", zout,zout)
+c
+c         CALL histdef(nid_mth, "cldTOA",
+c    .         "Cloud amount (satellite view)","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+c         CALL histdef(nid_mth, "cldSFC",
+c    .         "Cloud amount (surface view)","%",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .         "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "GWDtaux",
+     .         "GWD induced Ewd wind stress","Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+          CALL histdef(nid_mth, "GWDtauy",
+     .         "GWD induced Nwd wind stress","Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .         "ave(X)", zstophy,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "slp", "Sea Level Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zstophy,zout)
+c
+         CALL histdef(nid_mth, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zstophy,zout)
+c
+c        CALL histdef(nid_mth, "tsoil", "Sfce soil Temperature",
+c    .                "K",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "wind10m","10-m wind speed","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "q2m","Specific humidity 2m","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstorad,zout)
+c
+         CALL histdef(nid_mth, "qsurf","Surface Air humidity","kg/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      if (.not. ok_veget) then
+         CALL histdef(nid_mth, "qsol", "Soil watter content", "mm",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "ndayrain", 
+     .                "Number of day with rain (liq+sol)", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zstomth,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", 
+     .   "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "snowf", "Snow fall", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "evap", 
+     .                "Evaporation plus sublimation rate", "kg/(s*m2)",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tops0", "CS Solar rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupTOAclr", 
+     .                "SWup clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOAclr", 
+     .                "SWdn clear sky at TOA","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200", "SWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWup200clr", 
+     .                "SWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200", "SWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdn200clr", 
+     .                "SWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200", "LWup at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWup200clr", 
+     .                "LWup clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200", "LWdn at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "LWdn200clr", 
+     .                "LWdn clear sky at 200mb","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "radsol", "Rayonnement au sol", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWupSFCclr", 
+     .                "SWup clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFCclr", 
+     .                "SWdn clear sky at surface","W/m2",
+     .                iim,jj_nb,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFC","Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFC","Down. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWupSFCclr",
+     .                "CS Upwd. IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"LWdnSFCclr",
+     .                "Down. CS IR rad. at surface", 
+     .                "W/m2", iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+c          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+c    .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ffonte","Thermal flux for snow melting",
+     .                "W/m2",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fqcalving","Ice Calving",
+     .                "kg/m2/s",iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         DO nsrf = 1, nbsrf
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional wind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+         ENDDO
+c
+           call histdef(nid_mth, "pourc_"//clnsurf(is_oce), 
+     $         "% "//clnsurf(is_oce), "%",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fract_"//clnsurf(is_oce), 
+     $         "Fraction "//clnsurf(is_oce), "1",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Temperature "//clnsurf(nsrf), "K",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "flw_"//clnsurf(nsrf),
+     $         "LW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "fsw_"//clnsurf(nsrf),
+     $         "SW "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbils_"//clnsurf(nsrf),
+     $         "Bilan sol "//clnsurf(nsrf), "W/m2",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "wbilo_"//clnsurf(nsrf),
+     $         "Bilan eau "//clnsurf(nsrf), "kg/(m2*s)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+cIM 250105 BEG
+          IF(1.EQ.0) THEN
+C
+           call histdef(nid_mth, "evapour_"//clnsurf(nsrf),
+     $         "Evap*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+           call histdef(nid_mth, "prepour_"//clnsurf(nsrf),
+     $         "Precip*pourc "//clnsurf(nsrf), "kg/(s*m2)",
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+C
+          ENDIF !(1.EQ.0) THEN
+cIM 250105 END
+C
+         END DO
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "%",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"cldq","Cloud liquid water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"lwp","Cloud water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwp","Cloud ice water path","kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+cKE43
+      IF(iflag_con.GE.3) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/kg",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "mb",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "kg/m2/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "prw", "Precipitable water", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !iflag_con .GE. 3
+c34EK
+cIM cf. AM 081204 BEG
+c34EK
+c HBTM2
+         CALL histdef(nid_mth, "s_pblh", "Boundary Layer Height", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_pblt", "T at Boundary Layer Height",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_lcl", "Condensation level", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth,"s_capCL","Conv avlbl pot ener for ABL",
+     .                "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_oliqCL", "Liq Water in BL", "kg/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth,"s_cteiCL","Instability criteria (ABL)",
+     .                "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_therm", "Exces du thermique", "K",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb1", "deep_cape(HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb2", "inhibition (HBTM2)", "J/m2",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "s_trmb3", "Point Omega (HBTM2)", "m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+cIM cf. AM 081204 END
+c
+c Champs interpolles sur des niveaux de pression
+         DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+       IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+          CALL histdef(nid_mth, "u"//bb2,
+     .                 "Zonal wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "v"//bb2,
+     .                 "Meridional wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "w"//bb2,
+     .                 "Vertical wind "//bb2//"mb","m/s",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_mth, "phi"//bb2,
+     .                 "Geopotential "//bb2//"mb","m",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zout,zout)
+c
+         ENDIF !(bb2.EQ."850".OR.bb2.EQ."700"
+c
+       ENDDO !nlevSTD
+c
+cIM diagnostiques flux ocean-atm ou ocean-glace de mer
+cIM pour utilisation dans un modele de "slab" ocean
+c
+       CALL histdef(nid_mth, "fluxo",
+     .              "Flux turbulents ocean-atmosphere", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "fluxg",
+     .              "Flux turbulents ocean-glace de mer","W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_mth, "t_oce_sic",
+     .              "Temp. mixte oce-sic","K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       IF (OCEAN.EQ.'force ') THEN
+c
+        CALL histdef(nid_mth, "lmt_bils",
+     .       "Bilan au sol atmosphere forcee", "W/m2",
+     .       iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .       "ave(X)", zstophy,zout)
+c
+       ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+        CALL histdef(nid_mth, "slab_bils",
+     .              "Bilan au sol Slab", "W/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "tslab", "Slab SST ", "K",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "seaice", "Slab seaice", "kg/m2",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "siceh", "Slab seaice height", "m",
+     .              iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .              "ave(X)", zstophy,zout)
+c
+       ENDIF !OCEAN.EQ.slab/force
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+c
+c
+         CALL histdef(nid_mth,"lwcon","Cloud liquid water content",
+     .                "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"iwcon","Cloud ice water content","kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev, nvert, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+c        CALL histdef(nid_mth,"wvap","Water vapor mixing ratio","kg/kg",
+c    .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+c    .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "Pa/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+        CALL histdef(nid_mth, "rneb", "Cloud fraction", "%",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rnebcon", "Convective Cloud Fraction"
+     .                , "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "ppmv",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtphy", "Physics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqphy","Physics dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+        DO nsrf=1, nbsrf
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "-",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Rugosite "//clnsurf(nsrf), "m",  
+     $         iim,jj_nb,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+	 ENDDO !nsrf=1, nbsrf
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+      ENDIF !lev_histmth.GE.3
+c
+      IF(lev_histmth.GE.4) THEN
+c
+!FH Sorties pour la couche limite
+      if (iflag_pbl>1) then
+         CALL histdef(nid_mth, "tke","TKE","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "tke_max","TKE max","m2/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+      endif
+c
+         CALL histdef(nid_mth, "kz","Kz melange","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "kz_max","Kz melange max","m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "t_max(X)", zstophy,zout)
+
+
+
+
+         CALL histdef(nid_mth, "clwcon", 
+     .                "Convective Cloud Liquid water content"
+     .                , "kg/kg",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "kg/m2/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqdyn","Dynamics dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqcon","Convection dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlschr",
+     $       "Large-scale condensational heating rate", "K/s",
+     $       iim,jj_nb
+     $       ,nhori, klev,1,klev,nvert, 32,"ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqlsc","Condensation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dqvdf","Boundary-layer dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dqeva","Reevaporation dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+
+c
+         CALL histdef(nid_mth, "dqajs","Dry adjust. dQ","(kg/kg)/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "CS SW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth,"dtlw0","CS LW radiation dT","K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+         CALL histdef(nid_mth, "tau", "cloud opt thickness", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM1", "CCM1", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "CCM2", "CCM2", "",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "taupi", "cloud opt thickn. (pi)", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         CALL histdef(nid_mth, "cldemi", "emissivite IR", "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_ZERO", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AER", "?", "?",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_NAT", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AD", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOAAS_AI", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_ZERO", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AER", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_AD", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+	 CALL histdef(nid_mth, "SWTOACS_NAT", "?", "?",
+     .        iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .        "ave(X)", zstophy,zout)
+#endif
+#ifndef INCA
+         if (nqmax.GE.3) THEN
+         DO iq=3,nqmax
+         iiq=niadv(iq)
+         CALL histdef(nid_mth, tnom(iq), ttext(iiq), "-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zstophy,zout)
+         ENDDO
+         ENDIF
+#endif
+
+      ENDIF !lev_histmth.GE.4
+c
+      ENDIF !type_run.EQ."CLIM".OR.type_run.EQ."ENSP")
+c
+         CALL histend(nid_mth)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+c$OMP END MASTER
+      ENDIF ! fin de test sur ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histmthNMC.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histmthNMC.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histmthNMC.h	(revision 984)
@@ -0,0 +1,185 @@
+!
+! $Header$
+!
+      IF (ok_mensuel) THEN
+c
+c$OMP MASTER
+
+       zstophy = dtime
+       zstohf = ecrit_hf
+       zstomth = ecrit_mth
+       zout = ecrit_mth
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjmp1) = rlon(i+1)
+cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+cym         CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+cym     .                 nhori, nid_nmc)
+
+         CALL histbeg_phy("histNMC",itau_phy, zjulian, dtime, 
+     .                 nhori, nid_nmc)
+c
+         CALL histvert(nid_nmc, "presnivs", "Vertical levels", "mb",
+     .                 nlevSTD, rlevSTD/100., nvert)
+ccc
+ccc Champs 3D interpolles sur des niveaux de pression du NMC
+ccc
+      IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+          CALL histdef(nid_nmc, "temp",
+     .                 "Temperature","K",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "phi",
+     .                "Geopotential", "m",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "q",
+     .                 "Specific humidity","kg/kg",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "rh",
+     .                 "Relative humidity", "%",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "u",
+     .                 "Zonal wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "v",
+     .                 "Meridional wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+c             sur les niveaux du NMC et on somme & moyenne
+c             toutes les 6 heures par des routines undefSTD et
+c             moy_undefSTD pour eliminer les valeurs "undef"
+c             de la moyenne mensuelle
+c ======> le "inst(X)" ci-dessous est par consequence factice !
+c
+          CALL histdef(nid_nmc, "temp",
+     .                 "Temperature","K",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "phi",
+     .                "Geopotential ", "m",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "q",
+     .                 "Specific humidity","kg/kg",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+         CALL histdef(nid_nmc, "rh",
+     .                 "Relative humidity", "%",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "u",
+     .                 "Zonal wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "v",
+     .                 "Meridional wind","m/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "w",
+     .                 "Vertical motion","Pa/s",
+     .                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .                "inst(X)", zout,zout)
+c
+c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+c             sur les niveaux du NMC et on somme & moyenne
+c             toutes les 6 heures par des routines undefSTD et
+c             moy_undefSTD pour eliminer les valeurs "undef"
+c             de la moyenne mensuelle
+c ======> le "inst(X)" ci-dessus est par consequence factice !
+c
+c
+          CALL histdef(nid_nmc, "psbg",
+     .         "Pressure sfce below ground","%",
+     .         iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "uv",
+     .         "uv ",
+     .         "m2/s2",iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vq",
+     .         "vq ",
+     .         "m/s * (kg/kg)",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vT",
+     .         "vT ", 
+     .         "mK/s",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "wq",
+     .         "wq ", 
+     .         "(Pa/s)*(kg/kg)",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vphi",
+     .         "vphi ", 
+     .         "m2/s",iim,jj_nb,nhori, 
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "wT",
+     .         "wT ", 
+     .         "K*Pa/s",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "uxu",
+     .         "u2 ", 
+     .         "m2/s2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "vxv",
+     .         "v2 ", 
+     .         "m2/s2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+          CALL histdef(nid_nmc, "TxT",
+     .         "T2 ", 
+     .         "K2",iim,jj_nb,nhori,
+     .          nlevSTD,1,nlevSTD, nvert, 32,
+     .         "inst(X)", zout,zout)
+c
+      ENDIF !(type_run.EQ."AMIP")
+
+         CALL histend(nid_nmc)
+c
+c$OMP END MASTER
+
+      ENDIF ! fin de test sur ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_histrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_histrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_histrac.h	(revision 984)
@@ -0,0 +1,129 @@
+!
+! $Header$
+!
+#ifndef INCA
+c$OMP MASTER 
+         CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian)
+c
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = xlon(i+1)
+cym            zx_lon(i,jjm+1) = xlon(i+1)
+cym         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlat,zx_lat)
+cym         CALL histbeg("histrac", iim,zx_lon(:,1), jjm+1,zx_lat(1,:),
+cym     .                 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys,
+cym     .                 nhori, nid_tra)
+         CALL histbeg_phy("histrac", itau_phy, zjulian, pdtphys,
+     .                 nhori, nid_tra)
+         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+
+
+
+         zsto = pdtphys
+         zout = pdtphys * ecrit_tra
+c
+         CALL histdef(nid_tra, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+c
+         CALL histdef(nid_tra, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+         DO it=1,nqmax
+C champ 2D
+         iq=it+2
+         iiq=niadv(iq)
+         CALL histdef(nid_tra, tnom(iq), ttext(iiq), "U/kga",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         if (lessivage) THEN
+         CALL histdef(nid_tra, "fl"//tnom(iq),"Flux "//ttext(iiq),
+     .              "U/m2/s",iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .              "ave(X)", zsto,zout)
+         endif
+
+c---Ajout Olivia
+         CALL histdef(nid_tra, "d_tr_th_"//tnom(iq),
+     .	              "tendance thermique"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "d_tr_cv_"//tnom(iq),
+     .	              "tendance convection"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "d_tr_cl_"//tnom(iq),
+     .	              "tendance couche limite"// ttext(iiq), "?",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c---fin Olivia	 
+
+         ENDDO
+
+         CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+
+         CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf1", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf2", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf3", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "psrf4", "nature sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol1", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol2", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "ftsol3", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst",  zout,zout)
+         CALL histdef(nid_tra, "ftsol4", "temper sol", "-",
+     .                iim,jj_nb,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zout,zout)
+         CALL histdef(nid_tra, "pplay", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zout,zout)
+         CALL histdef(nid_tra, "t", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zout,zout)
+         CALL histdef(nid_tra, "mfu", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "mfd", "flux u decen","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_u", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_d", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_d", "flux u mont","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_u", "flux u decen","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "coefh", "turbulent coef","-",
+     .                iim,jj_nb,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+c
+         CALL histend(nid_tra)
+         ndex2d = 0
+         ndex3d = 0
+         ndex = 0
+c$OMP END MASTER
+#endif
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_paramLMDZ_phy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_paramLMDZ_phy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_paramLMDZ_phy.h	(revision 984)
@@ -0,0 +1,365 @@
+cym    Non implemente en mode parallele
+
+       IF (is_sequential) THEN  
+c
+       zstophy = dtime
+       zout = ecrit_day
+c
+       idayref = day_ref
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+c
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+       DO i = 1, iim
+         zx_lon(i,1) = rlon(i+1)
+         zx_lon(i,jjmp1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+c
+       CALL histbeg("paramLMDZ_phy.nc", 
+     .                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,1,1,1,
+     .                 itau_phy, zjulian, dtime,
+     .                 nhori, nid_ctesGCM)
+c
+c Variables type caractere : plusieurs valeurs possibles
+c
+       CALL histdef(nid_ctesGCM, "ocean", 
+     .        "Type ocean utilise: 1=force, 2=slab, 3=couple",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_slab_sicOBS",
+     ."ok_slab_sicOBS= 1: glace de mer observee, =0: gl.mer calculee 
+     . par le slab", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "type_run",
+     .        "Type run: 1= CLIM ou ENSP, 2= AMIP ou CFMI",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c Variables logiques (1=true, 0=false)
+c
+       CALL histdef(nid_ctesGCM, "ok_veget", 
+     .        "Type de modele de vegetation: 1=ORCHIDEE, 0=bucket",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_journe", 
+     .        "Creation du fichier histday: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_mensuel", 
+     .        "Creation du fichier histmth: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_instan", 
+     .        "Creation du fichier histins: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_ade", 
+     .        "Aerosol direct effect: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_aie", 
+     .        "Aerosol indirect effect: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "bl95_b0", 
+     .        "Parameter in CDNC-maer link (Boucher&Lohmann 1995)",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "bl95_b1", 
+     .        "Parameter in CDNC-maer link (Boucher&Lohmann 1995)",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ip_ebil_phy", 
+     .                "Niveau sortie diags bilan energie cote physique",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_ecc", 
+     .                "Excentricite","-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_peri", 
+     .                "Equinoxe","-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "R_incl", 
+     .                "Inclinaison","deg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "solaire", 
+     .                "Constante solaire","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "co2_ppm", 
+     .                "Concentration du CO2", "ppm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CH4_ppb", 
+     .                "Concentration du CH4", "ppb",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "N2O_ppb",
+     .                "Concentration du N2O", "ppb",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CFC11_ppt",
+     .                "Concentration du CFC11", "ppt",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "CFC12_ppt",
+     .                "Concentration du CFC12", "ppt",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "epmax",
+     .                "Efficacite precip", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_adj_ema",
+     .                "ok_adj_ema: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_clw",
+     .                "iflag_clw", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_lc_lsc",
+     .                "cld_lc_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_lc_con",
+     .                "cld_lc_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_tau_lsc",
+     .                "cld_tau_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cld_tau_con",
+     .                "cld_tau_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ffallv_lsc",
+     .                "ffallv_lsc", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ffallv_con",
+     .                "ffallv_con", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "coef_eva",
+     .                "coef_eva", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "reevap_ice",
+     .                "reevap_ice: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_cldcon",
+     .                "iflag_cldcon", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_pdf",
+     .                "iflag_pdf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "fact_cldcon",
+     .                "fact_cldcon", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "facttemps",
+     .                "facttemps", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_newmicro",
+     .                "Nouvelle micro-physique: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ratqsbas",
+     .                "ratqsbas", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ratqshaut",
+     .                "ratqshaut", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_froid",
+     .                "rad_froid", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_chau1",
+     .                "rad_chau1", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "rad_chau2",
+     .                "rad_chau2", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "top_height",
+     .                "top_height", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "overlap",
+     .                "overlap", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cdmmax",
+     .                "cdmmax", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "cdhmax",
+     .                "cdhmax", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ksta",
+     .                "ksta", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ksta_ter",
+     .                "ksta_ter", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_kzmin",
+     .                "ok_kzmin: 1=true, 0=false", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "iflag_pbl",
+     .                "iflag_pbl", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histhf",
+     .                "lev_histhf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histday",
+     .                "lev_histday", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lev_histmth",
+     .                "lev_histmth", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ok_isccp",
+     .                "Creation fichier histISCCP: 1=true, 0=false",
+     .                "-",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lonmin_ins",
+     .                "lonmin_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "lonmax_ins",
+     .                "lonmax_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "latmin_ins",
+     .                "latmin_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "latmax_ins",
+     .                "latmax_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_ins",
+     .                "ecrit_ins", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_hf",
+     .                "ecrit_hf", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_day",
+     .                "ecrit_day", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_mth",
+     .                "ecrit_mth", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_tra",
+     .                "ecrit_tra", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_reg",
+     .                "ecrit_reg", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "freq_ISCCP",
+     .                "freq_ISCCP", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+       CALL histdef(nid_ctesGCM, "ecrit_ISCCP",
+     .                "ecrit_ISCCP", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zstophy,zout)
+c
+c=================================================================
+c
+       CALL histend(nid_ctesGCM)
+       
+       ENDIF ! is_sequential
+c
+c=================================================================
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ini_undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ini_undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ini_undefSTD.F	(revision 984)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+
+      SUBROUTINE ini_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,
+     $           tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Initialisation - a des frequences differentes : 
+c
+c 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
+c    calculees a partir des valeurs "instantannees" de la physique
+c
+c 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
+c    toutes les 6 heures
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c              ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c              ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+c
+cym #include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym #include "dimphy.h"
+c variables Input/Output
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime
+      REAL ecrit_day,ecrit_mth
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+c
+c variables Output
+      REAL tnondef(klon,klevSTD,nout)
+      REAL tsumSTD(klon,klevSTD,nout)
+c
+c initialisation variables journalieres en debut de journee
+c
+      IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.1.) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,1)=0.
+         tsumSTD(i,k,1)=0.
+        ENDDO !i
+       ENDDO !k
+      ENDIF
+c
+c initialisation variables mensuelles (calculees a chaque pas de temps) 
+c en debut de mois : nout=2
+c
+      IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.1.) THEN
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,2)=0.
+         tsumSTD(i,k,2)=0.
+        ENDDO !i
+       ENDDO !k
+c
+c initialisation variables mensuelles - runs type Amip - (calculees toutes les 6h)
+c en debut de mois : nout = 3
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         tnondef(i,k,3)=0.
+         tsumSTD(i,k,3)=0.
+        ENDDO !i
+       ENDDO !k
+c
+      ENDIF
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phytherm/inifis.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/inifis.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/inifis.F	(revision 984)
@@ -0,0 +1,73 @@
+!
+! $Header$
+!
+      SUBROUTINE inifis(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,
+     $           prad,pg,pr,pcpp)
+      use dimphy
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon)
+      INTEGER pdayref
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon
+         STOP
+      ENDIF
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/iniphysiq.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/iniphysiq.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/iniphysiq.F	(revision 984)
@@ -0,0 +1,99 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE iniphysiq(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,pcu,pcv,
+     $           prad,pg,pr,pcpp)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE comgeomphy
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "comgeomphy.h"
+#include "YOMCST.h"
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon_glo)
+      REAL pcu(klon_glo),pcv(klon_glo)
+      INTEGER pdayref
+      INTEGER :: ibegin,iend,offset
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon_glo) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon_glo
+         STOP
+      ENDIF
+c$OMP PARALLEL PRIVATE(ibegin,iend) 
+c$OMP+         SHARED(parea,pcu,pcv,plon,plat)
+      
+      offset=klon_mpi_begin-1
+      airephy(1:klon_omp)=parea(offset+klon_omp_begin:
+     &                          offset+klon_omp_end)
+      cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end)
+      cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end)
+      rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end)
+      rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end)
+
+      call suphec
+
+c$OMP END PARALLEL
+
+      print*,'ATTENTION !!! TRAVAILLER SUR INIPHYSIQ'
+      print*,'CONTROLE DES LATITUDES, LONGITUDES, PARAMETRES ...'
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/init_phys_lmdz.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/init_phys_lmdz.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/init_phys_lmdz.F90	(revision 984)
@@ -0,0 +1,24 @@
+!
+!$Header$
+!
+SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nbtr,nb_proc,distrib)
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE dimphy, ONLY : Init_dimphy
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: llm
+    INTEGER,INTENT(in) :: nbtr
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+
+    CALL Init_grid_phy_lmdz(iim,jjp1,llm)
+    CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL Init_dimphy(klon_omp,nbp_lev,nbtr)
+!$OMP END PARALLEL
+ 
+END SUBROUTINE Init_Phys_lmdz  
Index: LMDZ4/tags/LF_20080728/libf/phytherm/initphysto.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/initphysto.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/initphysto.F	(revision 984)
@@ -0,0 +1,304 @@
+!
+! $Header$
+!
+C
+C
+      subroutine initphysto
+     .  (infile,
+     .  rlon, rlat, tstep,t_ops,t_wrt,nq,fileid)
+       
+       USE dimphy
+       USE mod_phys_lmdz_para
+       USE IOIPSL
+       USE iophy
+      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   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 "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+cym#include "dimphy.h"
+
+C   Arguments
+      character*(*) infile
+      integer*4 nhoriid, i
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq,l
+      real nivsigs(llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, idayref
+      logical ok_sync
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+C
+      REAL rlon(klon), rlat(klon)
+
+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 = 0
+	
+cym	CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+cym         DO i = 1, iim
+cym            zx_lon(i,1) = rlon(i+1)
+cym            zx_lon(i,jjm+1) = rlon(i+1)
+cym         ENDDO
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+
+
+      call histbeg_phy(infile,tau0, zjulian, tstep,
+     .                 nhoriid, fileid)
+
+c$OMP MASTER	
+C  Appel a histvert pour la grille verticale
+C
+	DO l=1,llm
+            nivsigs(l)=float(l)
+         ENDDO
+
+	write(*,*) 'avant histvert ds initphysto'
+
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+	write(*,*) 'apres histvert ds initphysto'
+
+       CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+c
+	write(*,*) 'apres phis ds initphysto'
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         write(*,*) 'apres aire ds initphysto'
+
+cym     Attention dtime et istphy ne sont pas �rit ---> a �iminer ?
+         CALL histdef(fileid, "dtime", "tps phys ", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	 CALL histdef(fileid, "istphy", "tps stock", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+C T 
+C
+      call histdef(fileid, 't', 'Temperature', 'K',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres t ds initphysto'
+C mfu 
+C
+      call histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres mfu ds initphysto'
+C
+C mfd 
+C
+      call histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_u 
+C
+      call histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+               write(*,*) 'apres en_u ds initphysto'
+C
+C de_u 
+C
+      call histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_d 
+C
+      call histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C de_d 
+C
+      call histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c coefh frac_impa,frac_nucl
+	
+	call histdef(fileid, "coefh", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c abderrahmane le 16 09 02
+        call histdef(fileid, "fm_th", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+        call histdef(fileid, "en_th", " ", " ",
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, "inst(X)", t_ops, t_wrt)
+c fin aj
+	
+	write(*,*) 'apres coefh ds initphysto'	
+
+	call histdef(fileid, 'frac_impa', ' ', ' ',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+	
+	call histdef(fileid, 'frac_nucl', ' ', ' ',
+     .             iim, jj_nb, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c
+c pyu1
+c
+      CALL histdef(fileid, "pyu1", " ", " ",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+
+c
+c pyv1
+c
+	CALL histdef(fileid, "pyv1", " ", " ",
+     .                iim,jj_nb,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'apres pyv1 ds initphysto'
+c
+c ftsol1
+c
+	call histdef(fileid, "ftsol1", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol2
+c
+        call histdef(fileid, "ftsol2", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol3
+c
+        call histdef(fileid, "ftsol3", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol4
+c
+        call histdef(fileid, "ftsol4", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c rain
+c
+        call histdef(fileid, "rain", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf1
+c
+	call histdef(fileid, "psrf1", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c psrf2
+c
+        call histdef(fileid, "psrf2", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf3
+c
+        call histdef(fileid, "psrf3", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf4
+c
+        call histdef(fileid, "psrf4", " ", " ",
+     .             iim, jj_nb, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'avant histend ds initphysto'	
+
+      call histend(fileid)
+c     if (ok_sync) call histsync(fileid)
+      if (ok_sync) call histsync
+c$OMP END MASTER
+	
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/initrrnpb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/initrrnpb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/initrrnpb.F	(revision 984)
@@ -0,0 +1,124 @@
+!
+! $Header$
+!
+      SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: initialisation des constantes des traceurs
+CAA Revison pour le controle avec la temperature du sol
+cAA
+CAA   it = 1 radon ss controle de ts
+cAA   it = 2 plomb ss controle de ts  
+c======================================================================
+c Arguments:
+c nbtr------input-I- nombre de vrais traceurs (sans l'eau)
+c ftsol-------input-R- Temperature du sol (Kelvin)
+c pctsrf-----input-R-  Nature de sol (pourcentage de sol)
+c masktr---output-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----output-R- Flux surfacique de production dans le sol
+c hsoltr---output-R- Epaisseur du reservoir de sol
+c tautr----output-R- Constante de decroissance du traceur
+c vdeptr---output-R- Vitesse de depot sec dans la couche Brownienne
+c scavtr---output-R- Coefficient de lessivage
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+c======================================================================
+C
+      INTEGER i, it
+      REAL pctsrf(klon,nbsrf) !Pourcentage de sol (f(nature du sol))
+      REAL ftsol(klon,nbsrf)  ! Temperature du sol pour le controle Rn
+c                             ! le cas echeant
+      REAL masktr(klon,nbtr)  ! Masque de l'echange avec la surface
+c                                 (possible => 1 )
+      REAL fshtr(klon,nbtr)  ! Flux surfacique dans le reservoir de sol
+      REAL hsoltr(nbtr)      ! Epaisseur equivalente du reservoir de sol
+      REAL tautr(nbtr)       ! Constante de decroissance radioactive
+      REAL vdeptr(nbtr)      ! Vitesse de depot sec dans la couche Brownienne
+      REAL scavtr(nbtr)      ! Coefficient de lessivage
+      REAL s
+C
+      WRITE(*,'(''PASSAGE initrrnpb ...'',$)')
+      print*,'nbtr= ',nbtr
+      print*,'nbsrf= ',nbsrf
+      print*,'klon= ',klon
+C
+C Puis les initialisation specifiques a chaque traceur (pour le moment, Rn222)
+C
+C
+C Radon it = 1
+c
+      IF ( nbtr .LE. 0 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 1
+      s = 1.E4  !  Source: atome par m2
+      hsoltr(it) = 0.1      ! Hauteur equivalente du reservoir : 
+c                              1 m * porosite 0.1
+      tautr(it) = 4.765E5  ! Decroissance du radon, secondes
+cAA
+c      tautr(it) = 4.765E55  ! Decroissance du radon,infinie
+cAA
+      vdeptr(it) = 0. ! Pas de depot sec pour le radon
+      scavtr(it) = 0. ! Pas de lessivage pour le radon
+
+      print*, '-------------- SOURCE DU RADON ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+
+      DO i = 1,klon
+        masktr(i,it) = 0.
+        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
+        fshtr(i,it) = s * masktr(i,it)
+
+cAA
+cAA quelques tests
+cAA POur l'instant le pctsrf(i,3) = 1.0 
+cAA lorsqu'il ya de la terre mias ne prend aucune autre valeur
+cAA il n'est donc pas necessaire de multiplier fshtr par pctsrf
+cAA 
+c       print*, '------------------------------------------ '
+c        print*, 'masktr(',i,it,')= ',masktr(i,it)
+c        print*, 'fshtr(',i,it,')= ',fshtr(i,it)
+c        print*, 'pctsrf(',i,',1)= ',pctsrf(i,1)
+c        print*, 'pctsrf(',i,',2)= ',pctsrf(i,2)
+c        print*, 'pctsrf(',i,',3)= ',pctsrf(i,3)
+c        print*, 'pctsrf(',i,',4)= ',pctsrf(i,4)
+c        print*, 's = ',s
+c        print*, '------------------------------------------ '
+
+      END DO
+C
+C 210Pb it = 2
+C
+      IF ( nbtr .LE. 1 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 2
+      s = 0. !  Pas de source !!!
+      hsoltr(it) = 10.     ! Hauteur equivalente du reservoir 
+c                              a partir duquel le
+c                              depot Brownien a lieu
+      tautr(it) = 1.028E9 ! Decroissance du Pb210, secondes
+      vdeptr(it) = 1.E-3 ! 1 mm/s pour le 210Pb
+      scavtr(it) =  .5   ! Lessivage du Pb210
+      DO i = 1,klon
+        masktr(i,it) = 1. ! Le depot sec peut avoir lieu partout
+        fshtr(i,it) = s * masktr(i,it)
+      END DO
+      print*, '-------------- SOURCE DU PLOMB ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir : ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+c
+      WRITE(*,*) 'initialisation rnpb ok'
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/interfoce_lim.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/interfoce_lim.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/interfoce_lim.F90	(revision 984)
@@ -0,0 +1,289 @@
+!
+! $Header$
+!
+SUBROUTINE interfoce_lim(itime, dtime, jour, &
+     knon, knindex, &
+     debut,  &
+     lmt_sst_p, pctsrf_new_p)
+  
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  
+  IMPLICIT NONE
+  
+  INCLUDE "indicesol.h"
+  INCLUDE "netcdf.inc"
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst_p      SST lues dans le fichier de CL
+!   pctsrf_new-p   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+!****************************************************************************************
+  INTEGER, INTENT(IN)                       :: itime
+  INTEGER, INTENT(IN)                       :: jour
+  INTEGER, INTENT(IN)                       :: knon
+  INTEGER, DIMENSION(klon_loc), INTENT(IN)  :: knindex
+  REAL   , INTENT(IN)                       :: dtime
+  LOGICAL, INTENT(IN)                       :: debut
+  
+! Parametres de sortie
+!****************************************************************************************
+  REAL, INTENT(OUT), DIMENSION(klon_loc)       :: lmt_sst_p
+  REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p
+
+
+! Variables locales avec l'attribut SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+  INTEGER,SAVE                              :: lmt_pas   
+  !$OMP THREADPRIVATE(lmt_pas)
+! pour indiquer que le jour a lire est deja lu pour une surface precedente
+  LOGICAL,SAVE                              :: deja_lu   
+  !$OMP THREADPRIVATE(deja_lu)
+  INTEGER,SAVE                              :: jour_lu 
+  !$OMP THREADPRIVATE(jour_lu)
+  CHARACTER (len = 20),SAVE                 :: fich ='limit.nc'
+  !$OMP THREADPRIVATE(fich)
+  LOGICAL, SAVE                             :: newlmt = .TRUE.
+  !$OMP THREADPRIVATE(newlmt)
+  LOGICAL, SAVE                             :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:)    :: sst_lu_p
+  !$OMP THREADPRIVATE(sst_lu_p)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:,:)  :: pct_tmp_p
+  !$OMP THREADPRIVATE(pct_tmp_p)
+
+! Variables locales 
+!****************************************************************************************
+  INTEGER                                   :: nid, nvarid
+  INTEGER                                   :: ii
+  INTEGER                                   :: ierr
+  INTEGER, DIMENSION(2)                     :: start, epais
+  CHARACTER (len = 20)                      :: modname = 'interfoce_lim'
+  CHARACTER (len = 80)                      :: abort_message
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pctsrf_new
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pct_tmp
+  REAL, DIMENSION(klon_glo)                 :: sst_lu
+  REAL, DIMENSION(klon_glo)                 :: nat_lu
+!
+! Fin declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! Start calculation
+!
+!****************************************************************************************
+  IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN
+     lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+     jour_lu = jour - 1
+     ALLOCATE(sst_lu_p(klon_loc))
+     ALLOCATE(pct_tmp_p(klon_loc,nbsrf))
+  ENDIF
+  
+  IF ((jour - jour_lu) /= 0) deja_lu = .FALSE.
+  
+  IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
+  IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime
+
+!****************************************************************************************
+! Ouverture et lecture du fichier pour le master process si c'est le bon moment
+!
+!****************************************************************************************
+! Tester d'abord si c'est le moment de lire le fichier
+  IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN
+
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+
+        fich = TRIM(fich)
+        ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+           abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+
+        ! La tranche de donnees a lire:
+
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+        IF (newlmt) THEN
+           !
+           ! Fraction "ocean" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FOCE> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FOCE>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glace de mer" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FSIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FSIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FTER> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FTER>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glacier terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FLIC> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FLIC>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           !
+        ELSE  ! on en est toujours a rnatur
+           ! 
+           ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <NAT> est absent'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu)
+#else
+           ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu)
+#endif
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <NAT>'
+              CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+!
+! Remplissage des fractions de surface
+! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
+! 
+           pct_tmp = 0.0
+           DO ii = 1, klon_glo
+              pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1.
+           ENDDO
+
+!
+!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
+!
+           pctsrf_new = pct_tmp
+           pctsrf_new (:,2)= pct_tmp (:,1)
+           pctsrf_new (:,1)= pct_tmp (:,2)
+           pct_tmp = pctsrf_new 
+        ENDIF ! fin test sur newlmt
+!
+! Lecture SST
+!
+        ierr = NF_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Le champ <SST> est absent'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu)
+#else
+        ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu)
+#endif
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Lecture echouee pour <SST>'
+           CALL abort_gcm(modname,abort_message,1)
+        ENDIF
+          
+!****************************************************************************************
+! Fin de lecture, fermeture de fichier
+!
+!****************************************************************************************
+        ierr = NF_CLOSE(nid)
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+!****************************************************************************************
+! Distribue les variables sur tous les processus
+!
+!****************************************************************************************
+     CALL Scatter(sst_lu,sst_lu_p)
+     CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
+     CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
+     deja_lu = .TRUE.
+     jour_lu = jour
+  ENDIF
+
+!****************************************************************************************
+! Recopie des variables dans les champs de sortie
+!
+!****************************************************************************************
+  lmt_sst_p = 999999999.
+  
+  DO ii = 1, knon
+     lmt_sst_p(ii) = sst_lu_p(knindex(ii))
+  ENDDO
+  
+  DO ii=1,klon_loc
+     pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
+     pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
+  ENDDO
+  
+  
+END SUBROUTINE interfoce_lim
Index: LMDZ4/tags/LF_20080728/libf/phytherm/iophy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/iophy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/iophy.F90	(revision 984)
@@ -0,0 +1,183 @@
+module iophy
+  
+  REAL,private,allocatable,dimension(:,:),save :: tmp_tab2d
+  REAL,private,allocatable,dimension(:,:,:),save :: tmp_tab3d
+  INTEGER,private,allocatable,dimension(:),save :: ndex2d
+  INTEGER,private,allocatable,dimension(:),save :: ndex3d
+  REAL,private,allocatable,dimension(:),save :: io_lat
+  REAL,private,allocatable,dimension(:),save :: io_lon
+  INTEGER, save :: phys_domain_id
+  
+  INTERFACE histwrite_phy
+    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy
+  END INTERFACE 
+
+contains
+
+  subroutine init_iophy(lat,lon)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  implicit none
+  include 'dimensions.h'   
+    real,dimension(iim),intent(in) :: lon
+    real,dimension(jjm+1),intent(in) :: lat
+
+    INTEGER,DIMENSION(2) :: ddid
+    INTEGER,DIMENSION(2) :: dsg
+    INTEGER,DIMENSION(2) :: dsl
+    INTEGER,DIMENSION(2) :: dpf
+    INTEGER,DIMENSION(2) :: dpl
+    INTEGER,DIMENSION(2) :: dhs
+    INTEGER,DIMENSION(2) :: dhe 
+
+!$OMP MASTER  
+    allocate(io_lat(jjm+1))
+    io_lat(:)=lat(:)
+    allocate(io_lon(iim))
+    io_lon(:)=lon(:)
+    allocate(tmp_tab2d(iim,jj_nb))
+    allocate(tmp_tab3d(iim,jj_nb,klev))
+    allocate(ndex2d(iim*jj_nb))
+    allocate(ndex3d(iim*jj_nb*klev))
+    ndex2d(:)=0
+    ndex3d(:)=0
+    
+    ddid=(/ 1,2 /)
+    dsg=(/ iim, jjm+1 /)
+    dsl=(/ iim, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',phys_domain_id)
+
+!$OMP END MASTER
+      
+  end subroutine init_iophy
+  
+  subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  use write_field
+  implicit none
+  include 'dimensions.h'
+    
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau0
+    real,intent(in) :: zjulian
+    real,intent(in) :: dtime
+    integer,intent(out) :: nhori
+    integer,intent(out) :: nid_day
+
+!$OMP MASTER    
+    if (is_sequential) then
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
+    else
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
+    endif
+!$OMP END MASTER
+  
+  end subroutine histbeg_phy
+  
+  subroutine histwrite2d_phy(nid,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  implicit none
+  include 'dimensions.h'
+    
+    integer,intent(in) :: nid
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(klon),intent(in) :: field
+    
+    REAL,dimension(klon_mpi) :: buffer_omp
+    
+    CALL Gather_omp(field,buffer_omp)    
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,tmp_tab2d)
+    CALL histwrite(nid,name,itau,tmp_tab2d,iim*jj_nb,ndex2d)
+!$OMP END MASTER    
+  end subroutine histwrite2d_phy
+  
+  subroutine histwrite3d_phy(nid,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+
+  use ioipsl
+  implicit none
+  include 'dimensions.h'
+    
+    integer,intent(in) :: nid
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(klon,klev),intent(in) :: field
+
+    REAL,dimension(klon_mpi,klev) :: buffer_omp
+    
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,tmp_tab3d)
+    CALL histwrite(nid,name,itau,tmp_tab3d,iim*jj_nb*klev,ndex3d)
+!$OMP END MASTER    
+  end subroutine histwrite3d_phy
+  
+  
+!  subroutine phy2dyn(field_phy,field_dyn,nlev)
+!  USE dimphy_old
+!  implicit none
+!  include 'dimensions.h'
+!  
+!    real,dimension(klon_mpi,nlev),intent(in) :: field_phy
+!    real,dimension(iim,jjphy_nb,nlev),intent(out) :: field_dyn
+!    integer,intent(in) :: nlev
+!    
+!    integer :: next
+!    integer :: j,l
+!    
+!      do l=1,nlev
+!        	
+!	if (jjphy_begin==jjphy_end) then
+!	  field_dyn(:,1,l)=0.
+!	  field_dyn(iiphy_begin:iiphy_end,1,l)=field_phy(1:klon_mpi,l)
+!	else
+!	
+!	 if (jjphy_begin==1) then
+!	    field_dyn(:,1,l)=field_phy(1,l)
+!	    next=2
+!	 else
+!	   field_dyn(:,1,l)=0.
+!	   next=iim-iiphy_begin+2
+!	   field_dyn(iiphy_begin:iim,1,l)=field_phy(1:next-1,l)   
+!	 endif
+!	
+!	  do j=2,jjphy_nb-1
+!	    field_dyn(:,j,l)=field_phy(next:next+iim-1,l)
+!	    next=next+iim
+!	  enddo
+!	  
+!	  if (jjphy_end==jjm+1) then
+!             field_dyn(:,jjphy_nb,l)=field_phy(klon_mpi,l)
+!	  else
+!	   field_dyn(:,jjphy_nb,l)=0.
+!	   field_dyn(1:iiphy_end,jjphy_nb,l)=field_phy(next:next+iiphy_end-1,l)   
+!	  endif
+!	  
+!	endif
+!     
+!     enddo
+!	 
+!    end subroutine phy2dyn	    
+  
+	  
+end module iophy
Index: LMDZ4/tags/LF_20080728/libf/phytherm/isccp_cloud_types.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/isccp_cloud_types.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/isccp_cloud_types.F	(revision 984)
@@ -0,0 +1,1668 @@
+!
+! $Header$
+!
+      SUBROUTINE ISCCP_CLOUD_TYPES(
+     &     debug,
+     &     debugcol,
+     &     npoints,
+     &     sunlit,
+     &     nlev,
+     &     ncol,
+     &     seed,
+     &     pfull,
+     &     phalf,
+     &     qv,
+     &     cc,
+     &     conv,
+     &     dtau_s,
+     &     dtau_c,
+     &     top_height,
+     &     overlap,
+     &     tautab,
+     &     invtau,
+     &     skt,
+     &     emsfc_lw,
+     &     at,dem_s,dem_c,
+     &     fq_isccp,
+     &     totalcldarea,
+     &     meanptop,
+     &     meantaucld,
+     &     boxtau,
+     &     boxptop
+     &)
+	
+
+! Copyright Steve Klein and Mark Webb 2002 - all rights reserved.
+!
+! This code is available without charge with the following conditions:
+!
+!  1. The code is available for scientific purposes and is not for 
+!     commercial use.
+!  2. Any improvements you make to the code should be made available 
+!     to the to the authors for incorporation into a future release.
+!  3. The code should not be used in any way that brings the authors 
+!     or their employers into disrepute.
+
+      implicit none
+
+!     NOTE:   the maximum number of levels and columns is set by
+!             the following parameter statement
+
+      INTEGER ncolprint
+      
+!     -----
+!     Input 
+!     -----
+
+      INTEGER npoints                   !  number of model points in the horizontal
+c      PARAMETER(npoints=6722)
+      INTEGER nlev                      !  number of model levels in column
+      INTEGER ncol                      !  number of subcolumns
+
+      INTEGER sunlit(npoints)           !  1 for day points, 0 for night time
+
+      INTEGER seed(npoints)             !  seed value for random number generator
+c                                       !  ( see Numerical Recipes Chapter 7)
+c                                       !  It is recommended that the seed is set
+c                                       !  to a different value for each model
+c                                       !  gridbox it is called on, as it is 
+c          				!  possible that the choice of the samec 
+c					!  seed value every time may introduce some
+c					!  statistical bias in the results, particularly
+c					!  for low values of NCOL.
+c
+      REAL pfull(npoints,nlev)	      	!  pressure of full model levels (Pascals)
+c                                        !  pfull(npoints,1)    is    top level of model
+c                                        !  pfull(npoints,nlev) is bottom level of model
+
+      REAL phalf(npoints,nlev+1)        !  pressure of half model levels (Pascals)
+c                                        !  phalf(npoints,1)    is    top       of model
+c                                        !  phalf(npoints,nlev+1) is the surface pressure
+
+      REAL qv(npoints,nlev)             !  water vapor specific humidity (kg vapor/ kg air)
+c                                        !         on full model levels
+
+      REAL cc(npoints,nlev)             !  input cloud cover in each model level (fraction) 
+c                                        !  NOTE:  This is the HORIZONTAL area of each
+c                                        !         grid box covered by clouds
+
+      REAL conv(npoints,nlev)           !  input convective cloud cover in each model level (fraction) 
+c                                        !  NOTE:  This is the HORIZONTAL area of each
+c                                        !         grid box covered by convective clouds
+
+      REAL dtau_s(npoints,nlev)         !  mean 0.67 micron optical depth of stratiform
+c					!  clouds in each model level
+c                                        !  NOTE:  this the cloud optical depth of only the
+c                                        !         cloudy part of the grid box, it is not weighted
+c                                        !         with the 0 cloud optical depth of the clear
+c                                        !         part of the grid box
+
+      REAL dtau_c(npoints,nlev)         !  mean 0.67 micron optical depth of convective
+c					!  clouds in each
+c                                        !  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
+c                                        !  infrared brightness temperature and the visible
+c					!  optical depth to adjust cloud top pressure. Note
+c					!  that this calculation is most appropriate to compare
+c					!  to ISCCP data during sunlit hours.
+c                                        !  2 = do not adjust top height, that is cloud top
+c                                        !  pressure is the actual cloud top pressure
+c                                        !  in the model
+c					!  3 = adjust top height using only the computed
+c					!  infrared brightness temperature. Note that this
+c					!  calculation is most appropriate to compare to ISCCP
+c					!  IR only algortihm (i.e. you can compare to nighttime
+c					!  ISCCP data with this option)
+
+      REAL tautab(0:255)                !  ISCCP table for converting count value to 
+c                                        !  optical thickness
+
+      INTEGER invtau(-20:45000)         !  ISCCP table for converting optical thickness 
+c                                        !  to count value
+!
+!     The following input variables are used only if top_height = 1 or top_height = 3
+!
+      REAL skt(npoints)                 !  skin Temperature (K)
+      REAL emsfc_lw                     !  10.5 micron emissivity of surface (fraction)                                            
+      REAL at(npoints,nlev)                   !  temperature in each model level (K)
+      REAL dem_s(npoints,nlev)                !  10.5 micron longwave emissivity of stratiform
+c					!  clouds in each
+c                                        !  model level.  Same note applies as in dtau_s.
+      REAL dem_c(npoints,nlev)                  !  10.5 micron longwave emissivity of convective
+c					!  clouds in each
+c                                        !  model level.  Same note applies as in dtau_s.
+cIM reg.dyn BEG
+      REAL t1, t2
+!     REAL w(npoints)                   !vertical wind at 500 hPa
+!     LOGICAL pct_ocean(npoints)        !TRUE if oceanic point, FALSE otherway
+!     INTEGER iw(npoints) , nw
+!     REAL wmin, pas_w
+!     INTEGER k, l, iwmx
+!     PARAMETER(wmin=-100.,pas_w=10.,iwmx=30)
+!     REAL fq_dynreg(7,7,iwmx)
+!     REAL nfq_dynreg(7,7,iwmx) 
+!     LOGICAL pctj(7,7,iwmx)
+cIM reg.dyn END
+!     ------
+!     Output
+!     ------
+
+      REAL fq_isccp(npoints,7,7)        !  the fraction of the model grid box covered by
+c                                        !  each of the 49 ISCCP D level cloud types
+
+      REAL totalcldarea(npoints)        !  the fraction of model grid box columns
+c                                        !  with cloud somewhere in them.  This should
+c					!  equal the sum over all entries of fq_isccp
+	
+	
+c      ! The following three means are averages over the cloudy areas only.  If no
+c      ! clouds are in grid box all three quantities should equal zero.	
+					
+      REAL meanptop(npoints)            !  mean cloud top pressure (mb) - linear averaging
+c                                        !  in cloud top pressure.
+					
+      REAL meantaucld(npoints)          !  mean optical thickness 
+c                                        !  linear averaging in albedo performed.
+      
+      REAL boxtau(npoints,ncol)         !  optical thickness in each column
+      
+      REAL boxptop(npoints,ncol)        !  cloud top pressure (mb) in each column
+					
+															
+!
+!     ------
+!     Working variables added when program updated to mimic Mark Webb's PV-Wave code
+!     ------
+
+      REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
+c					! Equivalent of BOX in original version, but
+c					! indexed by column then row, rather than
+c					! by row then column
+
+      REAL tca(npoints,0:nlev) ! total cloud cover in each model level (fraction)
+c                                        ! with extra layer of zeroes on top
+c                                        ! in this version this just contains the values input
+c                                        ! from cc but with an extra level
+      REAL cca(npoints,nlev)         ! convective cloud cover in each model level (fraction)
+c                                        ! from conv 
+
+      REAL threshold(npoints,ncol)   ! pointer to position in gridbox
+      REAL maxocc(npoints,ncol)      ! Flag for max overlapped conv cld
+      REAL maxosc(npoints,ncol)      ! Flag for max overlapped strat cld
+
+      REAL boxpos(npoints,ncol)      ! ordered pointer to position in gridbox
+
+      REAL threshold_min(npoints,ncol) ! minimum value to define range in with new threshold
+c                                        ! is chosen
+
+      REAL dem(npoints,ncol),bb(npoints)     !  working variables for 10.5 micron longwave 
+c					!  emissivity in part of
+c					!  gridbox under consideration
+
+      REAL ran(npoints)   	        ! vector of random numbers
+      REAL ptrop(npoints)
+      REAL attrop(npoints)
+      REAL attropmin (npoints)
+      REAL atmax(npoints)
+      REAL atmin(npoints)
+      REAL btcmin(npoints)
+      REAL transmax(npoints)
+
+      INTEGER i,j,ilev,ibox,itrop(npoints)
+      INTEGER ipres(npoints)
+      INTEGER itau(npoints),ilev2
+      INTEGER acc(nlev,ncol)
+      INTEGER match(npoints,nlev-1)
+      INTEGER nmatch(npoints)
+      INTEGER levmatch(npoints,ncol)
+      
+c      !variables needed for water vapor continuum absorption
+      real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints)
+      real taumin(npoints)
+      real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0
+      real press(npoints), dpress(npoints), atmden(npoints)
+      real rvh20(npoints), wk(npoints), rhoave(npoints)
+      real rh20s(npoints), rfrgn(npoints)
+      real tmpexp(npoints),tauwv(npoints)
+      
+      character*1 cchar(6),cchar_realtops(6)
+      integer icycle
+      REAL tau(npoints,ncol)
+      LOGICAL box_cloudy(npoints,ncol)
+      REAL tb(npoints,ncol)
+      REAL ptop(npoints,ncol)
+      REAL emcld(npoints,ncol)
+      REAL fluxtop(npoints,ncol)
+      REAL trans_layers_above(npoints,ncol)
+      real isccp_taumin,fluxtopinit(npoints),tauir(npoints)
+      real meanalbedocld(npoints) 
+      REAL albedocld(npoints,ncol)
+      real boxarea
+      integer debug       ! set to non-zero value to print out inputs
+c			  ! with step debug
+      integer debugcol    ! set to non-zero value to print out column
+c			  ! decomposition with step debugcol
+
+      integer index1(npoints),num1,jj
+      real rec2p13,tauchk
+
+      character*10 ftn09
+      
+      DATA isccp_taumin / 0.3 /
+      DATA cchar / ' ','-','1','+','I','+'/
+      DATA cchar_realtops / ' ',' ','1','1','I','I'/
+
+      tauchk = -1.*log(0.9999999)
+      rec2p13=1./2.13
+
+      ncolprint=0
+
+cIM
+c     PRINT*,' isccp_cloud_types npoints=',npoints
+c
+c      if ( debug.ne.0 ) then
+c          j=1
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write(6,'(a10)') 'debug='
+c          write(6,'(8I10)') debug
+c          write(6,'(a10)') 'debugcol='
+c          write(6,'(8I10)') debugcol
+c          write(6,'(a10)') 'npoints='
+c          write(6,'(8I10)') npoints
+c          write(6,'(a10)') 'nlev='
+c          write(6,'(8I10)') nlev
+c          write(6,'(a10)') 'ncol='
+c          write(6,'(8I10)') ncol
+c          write(6,'(a10)') 'top_height='
+c          write(6,'(8I10)') top_height
+c          write(6,'(a10)') 'overlap='
+c          write(6,'(8I10)') overlap
+c          write(6,'(a10)') 'emsfc_lw='
+c          write(6,'(8f10.2)') emsfc_lw
+c          write(6,'(a10)') 'tautab='
+c          write(6,'(8f10.2)') tautab
+c          write(6,'(a10)') 'invtau(1:100)='
+c          write(6,'(8i10)') (invtau(i),i=1,100)
+c	  do j=1,npoints,debug
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write(6,'(a10)') 'sunlit='
+c          write(6,'(8I10)') sunlit(j)
+c          write(6,'(a10)') 'seed='
+c          write(6,'(8I10)') seed(j)
+c          write(6,'(a10)') 'pfull='
+c          write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
+c          write(6,'(a10)') 'phalf='
+c          write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
+c          write(6,'(a10)') 'qv='
+c          write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
+c          write(6,'(a10)') 'cc='
+c          write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
+c          write(6,'(a10)') 'conv='
+c          write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dtau_s='
+c          write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dtau_c='
+c          write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
+c          write(6,'(a10)') 'skt='
+c          write(6,'(8f10.2)') skt(j)
+c          write(6,'(a10)') 'at='
+c          write(6,'(8f10.2)') (at(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dem_s='
+c          write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
+c          write(6,'(a10)') 'dem_c='
+c          write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev)
+c	  enddo
+c      endif
+
+!     ---------------------------------------------------!
+
+!     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
+
+!     assign 2d cca array using 1d input array conv
+
+      do ilev=1,nlev
+cIM pas besoin        do ibox=1,ncol
+          do j=1,npoints
+            cca(j,ilev)=conv(j,ilev)
+          enddo
+cIM        enddo
+      enddo
+
+cIM
+!     do j=1, iwmx
+!     do l=1, 7
+!     do k=1, 7
+!       fq_dynreg(k,l,j) =0. 
+!       nfq_dynreg(k,l,j) =0. 
+!      enddo !k
+!     enddo !l
+!     enddo !j
+cIM
+cIM
+c      if (ncolprint.ne.0) then
+c	do j=1,npoints,1000
+c        write(6,'(a10)') 'j='
+c        write(6,'(8I10)') j
+c        write (6,'(a)') 'seed:'
+c        write (6,'(I3.2)') seed(j)
+
+c        write (6,'(a)') 'tca_pp_rev:'
+c        write (6,'(8f5.2)') 
+c     &   ((tca(j,ilev)),
+c     &      ilev=1,nlev)
+
+c        write (6,'(a)') 'cca_pp_rev:'
+c        write (6,'(8f5.2)') 
+c     &   ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev)
+c	enddo
+c      endif
+
+      if (top_height .eq. 1 .or. top_height .eq. 3) then 
+
+      do j=1,npoints 
+          ptrop(j)=5000.
+          atmin(j) = 400.
+          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
+           if (at(j,ilev) .gt. atmax(j)) atmax(j)=at(j,ilev)
+           if (at(j,ilev) .lt. atmin(j)) atmin(j)=at(j,ilev)
+        enddo
+12    continue
+
+      end if
+
+!     -----------------------------------------------------!
+
+!     ---------------------------------------------------!
+
+cIM
+c     do 13 ilev=1,nlev
+cnum1=0
+c       do j=1,npoints
+c           if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  ' error = cloud fraction less than zero'
+c	write(6,*) ' or '
+c               write(6,*)  ' error = cloud fraction greater than 1'
+c	write(6,*) 'value at point ',j,' is ',cc(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+cnum1=0
+c       do j=1,npoints
+c           if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud fraction less than zero'
+c	write(6,*) ' or '
+c               write(6,*)  
+c    &           ' error = convective cloud fraction greater than 1'
+c	write(6,*) 'value at point ',j,' is ',conv(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dtau_s(j,ilev) .lt. 0.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = stratiform cloud opt. depth less than zero'
+c	write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+cnum1=0
+c       do j=1,npoints
+c           if (dtau_c(j,ilev) .lt. 0.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud opt. depth less than zero'
+c	write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = stratiform cloud emissivity less than zero'
+c	write(6,*)'or'
+c               write(6,*)  
+c    &           ' error = stratiform cloud emissivity greater than 1'
+c	write(6,*) 'value at point ',j,' is ',dem_s(j,ilev)
+c	write(6,*) 'level ',ilev
+c               STOP
+c       enddo
+
+cnum1=0
+c       do j=1,npoints
+c           if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
+c	num1=num1+1
+c	index1(num1)=j
+c           end if
+c       enddo
+c       do jj=1,num1   
+c	j=index1(jj)
+c               write(6,*)  
+c    &           ' error = convective cloud emissivity less than zero'
+c	write(6,*)'or'
+c               write(6,*)  
+c    &           ' error = convective cloud emissivity greater than 1'
+c               write (6,*) 
+c    &          'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev) 
+c               STOP
+c       enddo
+c13    continue
+
+
+      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 ibox=1,ncol
+        do ilev=1,nlev
+          do j=1,npoints
+	    frac_out(j,ibox,ilev)=0.0
+          enddo
+        enddo
+      enddo
+
+cIM
+c      if (ncolprint.ne.0) then
+c        write (6,'(a)') 'frac_out_pp_rev:'
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(8f5.2)') 
+c     &     ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
+
+c          enddo
+c        write (6,'(a)') 'ncol:'
+c        write (6,'(I3)') ncol
+c      endif
+c      if (ncolprint.ne.0) then
+c        write (6,'(a)') 'last_frac_pp:'
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(8f5.2)') (tca(j,0))
+c          enddo
+c      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
+                call ran0_vec(npoints,seed,ran)
+	        ! select random pixels from the non-convective
+	        ! part the gridbox ( some will be converted into
+	        ! convective pixels below )
+                do j=1,npoints
+                  threshold(j,ibox)=
+     &            cca(j,ilev)+(1-cca(j,ilev))*ran(j)
+                enddo
+              enddo
+            ENDIF
+cIM
+c            IF (ncolprint.ne.0) then
+c              write (6,'(a)') 'threshold_nsf2:'
+c                do j=1,npoints,1000
+c                write(6,'(a10)') 'j='
+c                write(6,'(8I10)') j
+c                write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+c                enddo
+c            ENDIF
+        ENDIF
+
+c        IF (ncolprint.ne.0) then
+c            write (6,'(a)') 'ilev:'
+c            write (6,'(I2)') ilev
+c        ENDIF
+
+        DO ibox=1,ncol
+
+          ! All versions
+          do j=1,npoints
+            if (boxpos(j,ibox).le.cca(j,ilev)) then
+cIM REAL           maxocc(j,ibox) = 1
+              maxocc(j,ibox) = 1.0
+            else
+cIM REAL           maxocc(j,ibox) = 0
+              maxocc(j,ibox) = 0.0
+            end if
+          enddo
+
+          ! Max overlap
+          if (overlap.eq.1) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=cca(j,ilev)
+cIM REAL           maxosc(j,ibox)=1
+              maxosc(j,ibox)=1.0
+            enddo
+          endif
+
+          ! Random overlap
+          if (overlap.eq.2) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=cca(j,ilev)
+cIM REAL           maxosc(j,ibox)=0
+              maxosc(j,ibox)=0.0
+            enddo
+          endif
+
+          ! Max/Random overlap
+          if (overlap.eq.3) then 
+            do j=1,npoints
+              threshold_min(j,ibox)=max(cca(j,ilev),
+     &          min(tca(j,ilev-1),tca(j,ilev)))
+              if (threshold(j,ibox)
+     &          .lt.min(tca(j,ilev-1),tca(j,ilev))
+     &          .and.(threshold(j,ibox).gt.cca(j,ilev))) then
+cIM REAL                maxosc(j,ibox)= 1
+                   maxosc(j,ibox)= 1.0
+              else
+cIM REAL                 maxosc(j,ibox)= 0
+                   maxosc(j,ibox)= 0.0
+              end if
+            enddo
+          endif
+    
+          ! Reset threshold 
+          call ran0_vec(npoints,seed,ran)
+	   
+          do j=1,npoints
+            threshold(j,ibox)=
+              !if max overlapped conv cloud
+     &        maxocc(j,ibox) * (                                       
+     &            boxpos(j,ibox)                                               
+     &        ) +                                                      
+              !else
+     &        (1-maxocc(j,ibox)) * (                                   
+                  !if max overlapped strat cloud
+     &            (maxosc(j,ibox)) * (                                 
+                      !threshold=boxpos
+     &                threshold(j,ibox)                                        
+     &            ) +                                                  
+                  !else
+     &            (1-maxosc(j,ibox)) * (                               
+                      !threshold_min=random[thrmin,1]
+     &                threshold_min(j,ibox)+
+     &                  (1-threshold_min(j,ibox))*ran(j)  
+     &           ) 
+     &        )
+          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
+cIM REAL             frac_out(j,ibox,ilev)=1
+               frac_out(j,ibox,ilev)=1.0
+               else
+cIM REAL             frac_out(j,ibox,ilev)=0
+               frac_out(j,ibox,ilev)=0.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.cca(j,ilev)) then
+                    ! = 2 IF threshold le cca(j)
+cIM REAL                  frac_out(j,ibox,ilev) = 2 
+                    frac_out(j,ibox,ilev) = 2.0 
+                else
+                    ! = the same IF NOT threshold le cca(j) 
+                    frac_out(j,ibox,ilev) = frac_out(j,ibox,ilev)
+                end if
+             enddo
+           ENDDO
+
+!         Set last_frac to tca at this level, so as to be tca 
+!         from last level next time round
+
+cIM
+c          if (ncolprint.ne.0) then
+
+c            do j=1,npoints ,1000
+c            write(6,'(a10)') 'j='
+c            write(6,'(8I10)') j
+c            write (6,'(a)') 'last_frac:'
+c            write (6,'(8f5.2)') (tca(j,ilev-1))
+    
+c            write (6,'(a)') 'cca:'
+c            write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'max_overlap_cc:'
+c            write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'max_overlap_sc:'
+c            write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'threshold_min_nsf2:'
+c            write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'threshold_nsf2:'
+c            write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'frac_out_pp_rev:'
+c            write (6,'(8f5.2)') 
+c     &       ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+c	    enddo
+c          endif
+
+200   CONTINUE    !loop over nlev
+
+!
+!     ---------------------------------------------------!
+
+      
+!
+!     ---------------------------------------------------!
+!     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)=0.
+	    boxptop(j,ibox)=0.
+	    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 
+cIM REAL              if (frac_out(j,ibox,ilev).eq.1) then
+                 if (frac_out(j,ibox,ilev).eq.1.0) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_s(j,ilev)
+                 endif
+cIM REAL              if (frac_out(j,ibox,ilev).eq.2) then
+                 if (frac_out(j,ibox,ilev).eq.2.0) then
+                        tau(j,ibox)=tau(j,ibox)
+     &                     + dtau_c(j,ilev)
+                 end if
+              enddo
+            enddo ! ibox
+      enddo ! ilev
+cIM
+c          if (ncolprint.ne.0) then
+
+c              do j=1,npoints ,1000
+c                write(6,'(a10)') 'j='
+c                write(6,'(8I10)') j
+c                write(6,'(i2,1X,8(f7.2,1X))') 
+c     &          ilev,
+c     &          (tau(j,ibox),ibox=1,ncolprint)
+c              enddo
+c          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.
+cIM
+c        if (ncolprint .ne. 0) 
+c     &         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
+cIM
+c               if (ncolprint .ne. 0) then
+c               do j=1,npoints ,1000
+c               write(6,'(a10)') 'j='
+c               write(6,'(8I10)') j
+c               write(6,'(i2,1X,3(f8.3,3X))') ilev,
+c     &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
+c     &           tauwv(j),dem_wv(j,ilev)
+c               enddo
+c	       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 
+cIM  
+c            if (ncolprint.ne.0) then
+c             do j=1,npoints ,1000
+c              write(6,'(a10)') 'j='
+c              write(6,'(8I10)') j
+c              write (6,'(a)') 'ilev:'
+c              write (6,'(I2)') ilev
+    
+c              write (6,'(a)') 
+c     &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
+c              write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
+c     &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
+c             enddo   
+c            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)
+        enddo
+
+cIM
+c        if (ncolprint.ne.0) then
+c        do j=1,npoints ,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(a)') 'id:'
+c          write (6,'(a)') 'surface'
+
+c          write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
+c          write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j),
+c     &      100.*fluxtop_clrsky(j),
+c     &       trans_layers_above_clrsky(j)
+c        enddo
+c	endif
+    
+
+        !
+        !           END OF CLEAR SKY CALCULATION
+        !
+        !----------------------------------------------------------------
+
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c        do j=1,npoints ,1000
+c            write(6,'(a10)') 'j='
+c            write(6,'(8I10)') j
+c            write (6,'(a)') 'ts:'
+c            write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
+    
+c            write (6,'(a)') 'ta_rev:'
+c            write (6,'(8f7.2)') 
+c     &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+
+c        enddo
+c        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
+cIM REAL             if (frac_out(j,ibox,ilev).eq.1) then
+                if (frac_out(j,ibox,ilev).eq.1.0) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_s(j,ilev)) )
+cIM REAL             else if (frac_out(j,ibox,ilev).eq.2) then
+                else if (frac_out(j,ibox,ilev).eq.2.0) then
+                dem(j,ibox)= 1. - 
+     &             ( (1. - dem_wv(j,ilev)) * (1. -  dem_c(j,ilev)) )
+                else
+                dem(j,ibox)=  dem_wv(j,ilev)
+                end if
+                
+
+                ! increase TOA flux by flux emitted from layer
+	        ! times total transmittance in layers above
+
+                fluxtop(j,ibox) = fluxtop(j,ibox) 
+     &            + dem(j,ibox) * bb(j)
+     &            * trans_layers_above(j,ibox) 
+            
+                ! update trans_layers_above with transmissivity
+	        ! from this layer for next time around loop
+
+                trans_layers_above(j,ibox)=
+     &            trans_layers_above(j,ibox)*(1.-dem(j,ibox))
+
+              enddo ! j
+            enddo ! ibox
+
+cIM
+c            if (ncolprint.ne.0) then
+c              do j=1,npoints,1000
+c              write (6,'(a)') 'ilev:'
+c              write (6,'(I2)') ilev
+    
+c              write(6,'(a10)') 'j='
+c              write(6,'(8I10)') j
+c              write (6,'(a)') 'emiss_layer:'
+c              write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
+        
+c              write (6,'(a)') '100.*bb(j):'
+c              write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+        
+c              write (6,'(a)') '100.*f:'
+c              write (6,'(8f7.2)') 
+c     &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+        
+c              write (6,'(a)') 'total_trans:'
+c              write (6,'(8f7.2)') 
+c     &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
+c	      enddo
+c          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
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c          do j=1,npoints ,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+c          write (6,'(a)') 'id:'
+c          write (6,'(a)') 'surface'
+
+c          write (6,'(a)') 'emiss_layer:'
+c          write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') '100.*bb(j):'
+c          write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+    
+c          write (6,'(a)') '100.*f:'
+c          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+c          end do
+c	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
+                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) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
+            end if
+          enddo ! j
+        enddo ! ibox
+
+cIM
+c        if (ncolprint.ne.0) then
+
+c          do j=1,npoints,1000
+c          write(6,'(a10)') 'j='
+c          write(6,'(8I10)') j
+
+c          write (6,'(a)') 'attrop:'
+c          write (6,'(8f7.2)') (attrop(j))
+    
+c          write (6,'(a)') 'btcmin:'
+c          write (6,'(8f7.2)') (btcmin(j))
+    
+c          write (6,'(a)') 'fluxtop_clrsky*100:'
+c          write (6,'(8f7.2)') 
+c     &      (100.*fluxtop_clrsky(j))
+
+c          write (6,'(a)') '100.*f_adj:'
+c          write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'transmax:'
+c          write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'tau:'
+c          write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'emcld:'
+c          write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_trans:'
+c          write (6,'(8f7.2)') 
+c     &	  (trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_emiss:'
+c          write (6,'(8f7.2)') 
+c     &	  (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'total_trans:'
+c          write (6,'(8f7.2)') 
+c     &	  (trans_layers_above(j,ibox),ibox=1,ncolprint)
+    
+c          write (6,'(a)') 'ppout:'
+c          write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+c          enddo ! j
+c	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 ilev=1,nlev-1
+            !cdir nodep
+            do j=1,npoints 
+              if ((at(j,ilev)   .ge. tb(j,ibox) .and. 
+     &          at(j,ilev+1) .lt. tb(j,ibox)) .or.
+     &          (at(j,ilev) .le. tb(j,ibox) .and. 
+     &          at(j,ilev+1) .gt. tb(j,ibox))) then 
+   
+                nmatch(j)=nmatch(j)+1
+                if(abs(at(j,ilev)-tb(j,ibox)) .lt.
+     &            abs(at(j,ilev+1)-tb(j,ibox))) then
+                  match(j,nmatch(j))=ilev
+                else
+                  match(j,nmatch(j))=ilev+1
+                end if
+              end if                        
+            enddo
+29        continue
+
+          do j=1,npoints 
+            if (nmatch(j) .ge. 1) then
+              ptop(j,ibox)=pfull(j,match(j,nmatch(j)))
+              levmatch(j,ibox)=match(j,nmatch(j))   
+            else
+              if (tb(j,ibox) .lt. atmin(j)) then
+                ptop(j,ibox)=ptrop(j)
+                levmatch(j,ibox)=itrop(j)
+              end if
+              if (tb(j,ibox) .gt. 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. )
+cIM  &           .and.(frac_out(j,ibox,ilev) .ne. 0)) then
+     &           .and.(frac_out(j,ibox,ilev) .ne. 0.0)) then
+                ptop(j,ibox)=pfull(j,ilev)
+	        levmatch(j,ibox)=ilev
+              end if
+            end do
+          end do
+        end if                            
+          
+        do j=1,npoints
+          if (tau(j,ibox) .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 ! 
+             fq_isccp(j,ilev,ilev2)=0.
+        enddo
+38    continue
+
+      !reset variables need for averaging cloud properties
+      do j=1,npoints 
+        totalcldarea(j) = 0.
+        meanalbedocld(j) = 0.
+        meanptop(j) = 0.
+        meantaucld(j) = 0.
+      enddo ! j
+
+      boxarea = 1./real(ncol)
+     
+              !determine optical depth category
+cIM       do 39 j=1,npoints
+cIM       do ibox=1,ncol
+        do 39 ibox=1,ncol
+          do j=1,npoints
+
+cIM
+c         CALL CPU_time(t1)
+cIM
+
+          if (tau(j,ibox) .gt. (tauchk            )
+     &      .and. ptop(j,ibox) .gt. 0.) then
+              box_cloudy(j,ibox)=.true.
+          endif
+
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF tau t2 - t1',t2 - t1
+
+c         CALL CPU_time(t1)
+cIM
+
+          if (box_cloudy(j,ibox)) then
+
+              ! totalcldarea always diagnosed day or night
+              totalcldarea(j) = totalcldarea(j) + boxarea
+
+              if (sunlit(j).eq.1) then
+
+                ! tau diagnostics only with sunlight
+
+                boxtau(j,ibox) = tau(j,ibox)
+
+                !convert optical thickness to albedo
+  	        albedocld(j,ibox)
+     &            =real(invtau(min(nint(100.*tau(j,ibox)),45000)))
+	    
+                !contribute to averaging
+	        meanalbedocld(j) = meanalbedocld(j) 
+     &            +albedocld(j,ibox)*boxarea
+
+            endif
+
+          endif
+          
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF box_cloudy t2 - t1',t2 - t1
+          
+c         CALL CPU_time(t1)
+cIM BEG 
+cIM           !convert ptop to millibars
+              ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+cIM           !save for output cloud top pressure and optical thickness
+              boxptop(j,ibox) = ptop(j,ibox)
+cIM END
+
+cIM BEG
+              !reset itau(j), ipres(j)
+              itau(j) = 0
+              ipres(j) = 0
+
+              if (tau(j,ibox) .lt. isccp_taumin) then
+                  itau(j)=1
+              else if (tau(j,ibox) .ge. isccp_taumin
+     &                                    
+     &          .and. tau(j,ibox) .lt. 1.3) then
+                itau(j)=2
+              else if (tau(j,ibox) .ge. 1.3 
+     &          .and. tau(j,ibox) .lt. 3.6) then
+                itau(j)=3
+              else if (tau(j,ibox) .ge. 3.6 
+     &          .and. tau(j,ibox) .lt. 9.4) then
+                  itau(j)=4
+              else if (tau(j,ibox) .ge. 9.4 
+     &          .and. tau(j,ibox) .lt. 23.) then
+                  itau(j)=5
+              else if (tau(j,ibox) .ge. 23. 
+     &          .and. tau(j,ibox) .lt. 60.) then
+                  itau(j)=6
+              else if (tau(j,ibox) .ge. 60.) then
+                  itau(j)=7
+              end if
+
+              !determine cloud top pressure category
+              if (    ptop(j,ibox) .gt. 0.  
+     &          .and.ptop(j,ibox) .lt. 180.) then
+                  ipres(j)=1
+              else if(ptop(j,ibox) .ge. 180.
+     &          .and.ptop(j,ibox) .lt. 310.) then
+                  ipres(j)=2
+              else if(ptop(j,ibox) .ge. 310.
+     &          .and.ptop(j,ibox) .lt. 440.) then
+                  ipres(j)=3
+              else if(ptop(j,ibox) .ge. 440.
+     &          .and.ptop(j,ibox) .lt. 560.) then
+                  ipres(j)=4
+              else if(ptop(j,ibox) .ge. 560.
+     &          .and.ptop(j,ibox) .lt. 680.) then
+                  ipres(j)=5
+              else if(ptop(j,ibox) .ge. 680.
+     &          .and.ptop(j,ibox) .lt. 800.) then
+                  ipres(j)=6
+              else if(ptop(j,ibox) .ge. 800.) then
+                  ipres(j)=7
+              end if 
+cIM END
+
+          if (sunlit(j).eq.1 .or. top_height .eq. 3) then 
+
+cIM         !convert ptop to millibars
+cIM           ptop(j,ibox)=ptop(j,ibox) / 100.
+            
+cIM         !save for output cloud top pressure and optical thickness
+cIM             boxptop(j,ibox) = ptop(j,ibox)
+    
+            if (box_cloudy(j,ibox)) then
+	    
+              meanptop(j) = meanptop(j) + ptop(j,ibox)*boxarea
+
+cIM             !reset itau(j), ipres(j)
+cIM           itau(j) = 0
+cIM           ipres(j) = 0
+
+c             if (tau(j,ibox) .lt. isccp_taumin) then
+c                 itau(j)=1
+c             else if (tau(j,ibox) .ge. isccp_taumin
+c    &                                    
+c    &          .and. tau(j,ibox) .lt. 1.3) then
+c               itau(j)=2
+c             else if (tau(j,ibox) .ge. 1.3 
+c    &          .and. tau(j,ibox) .lt. 3.6) then
+c               itau(j)=3
+c             else if (tau(j,ibox) .ge. 3.6 
+c    &          .and. tau(j,ibox) .lt. 9.4) then
+c                 itau(j)=4
+c             else if (tau(j,ibox) .ge. 9.4 
+c    &          .and. tau(j,ibox) .lt. 23.) then
+c                 itau(j)=5
+c             else if (tau(j,ibox) .ge. 23. 
+c    &          .and. tau(j,ibox) .lt. 60.) then
+c                 itau(j)=6
+c             else if (tau(j,ibox) .ge. 60.) then
+c                 itau(j)=7
+c             end if
+
+c             !determine cloud top pressure category
+c             if (    ptop(j,ibox) .gt. 0.  
+c    &          .and.ptop(j,ibox) .lt. 180.) then
+c                 ipres(j)=1
+c             else if(ptop(j,ibox) .ge. 180.
+c    &          .and.ptop(j,ibox) .lt. 310.) then
+c                 ipres(j)=2
+c             else if(ptop(j,ibox) .ge. 310.
+c    &          .and.ptop(j,ibox) .lt. 440.) then
+c                 ipres(j)=3
+c            else if(ptop(j,ibox) .ge. 440.
+c    &          .and.ptop(j,ibox) .lt. 560.) then
+c                 ipres(j)=4
+c             else if(ptop(j,ibox) .ge. 560.
+c    &          .and.ptop(j,ibox) .lt. 680.) then
+c                 ipres(j)=5
+c             else if(ptop(j,ibox) .ge. 680.
+c    &          .and.ptop(j,ibox) .lt. 800.) then
+c                 ipres(j)=6
+c             else if(ptop(j,ibox) .ge. 800.) then
+c                 ipres(j)=7
+c             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
+
+cIM calcul stats regime dynamique BEG
+!             iw(j) = int((w(j)-wmin)/pas_w) +1
+!             pctj(itau(j),ipres(j),iw(j))=.FALSE.
+!             !update frequencies W500
+!             if (pct_ocean(j)) then
+!             if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+!             if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+c             print*,' ISCCP iw=',iw(j),j
+!             fq_dynreg(itau(j),ipres(j),iw(j))=
+!    &          fq_dynreg(itau(j),ipres(j),iw(j))+
+!    &          boxarea
+c    &          fq_isccp(j,itau(j),ipres(j))
+!             pctj(itau(j),ipres(j),iw(j))=.TRUE.
+c             nfq_dynreg(itau(j),ipres(j),iw(j))=
+c    &          nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+!              end if
+!             end if
+!             end if
+cIM calcul stats regime dynamique END
+            end if !IM boxcloudy
+
+          end if !IM sunlit
+                       
+cIM
+c         CALL CPU_time(t2)
+c         print*,'IF sunlit boxcloudy t2 - t1',t2 - t1
+cIM
+        enddo !IM ibox/j
+
+
+cIM ajout stats s/ W500 BEG
+cIM ajout stats s/ W500 END
+
+c             if(j.EQ.6722) then
+c             print*,' ISCCP',w(j),iw(j),ipres(j),itau(j)
+c             endif
+
+!     if (pct_ocean(j)) then
+!     if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+!     if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+!     if(pctj(itau(j),ipres(j),iw(j))) THEN 
+!         nfq_dynreg(itau(j),ipres(j),iw(j))=
+!    &    nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+c         if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND.
+c    &    iw(j).EQ.10) then
+c         PRINT*,' isccp AVANT',
+c    &    nfq_dynreg(itau(j),ipres(j),iw(j)),
+c    &    fq_dynreg(itau(j),ipres(j),iw(j))
+c         endif
+!     endif
+!     endif
+!     endif
+!     endif
+39    continue !IM j/ibox
+      
+      !compute mean cloud properties
+      do j=1,npoints 
+        if (totalcldarea(j) .gt. 0.) then
+ 	  meanptop(j) = meanptop(j) / totalcldarea(j)
+          if (sunlit(j).eq.1) then
+            meanalbedocld(j) = meanalbedocld(j) / totalcldarea(j)
+	    meantaucld(j) = tautab(min(255,max(1,nint(meanalbedocld(j))))) 
+          end if
+        end if
+      enddo ! j
+!
+cIM ajout stats s/ W500 BEG
+!     do nw = 1, iwmx
+!     do l = 1, 7
+!     do k = 1, 7
+!       if (nfq_dynreg(k,l,nw).GT.0.) then
+!       fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw)
+c        if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then
+c        print*,' isccp APRES',nfq_dynreg(k,l,nw),
+c    &   fq_dynreg(k,l,nw)
+c        endif
+!       else
+!        if(fq_dynreg(k,l,nw).NE.0.) then
+!        print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw)
+!        endif 
+c        fq_dynreg(k,l,nw) = -1.E+20
+c        nfq_dynreg(k,l,nw) = 1.E+20
+!       end if 
+!     enddo !k
+!     enddo !l
+!     enddo !nw
+cIM ajout stats s/ W500 END
+!     ---------------------------------------------------!
+
+!     ---------------------------------------------------!
+!     OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
+!
+!cIM
+c      if (debugcol.ne.0) then
+!     
+c         do j=1,npoints,debugcol
+
+c            !produce character output
+c            do ilev=1,nlev
+c              do ibox=1,ncol
+c                   acc(ilev,ibox)=0
+c              enddo
+c            enddo
+
+c            do ilev=1,nlev
+c              do ibox=1,ncol
+c                   acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
+c                   if (levmatch(j,ibox) .eq. ilev) 
+c     &                 acc(ilev,ibox)=acc(ilev,ibox)+1
+c              enddo
+c            enddo
+
+             !print test
+
+c          write(ftn09,11) j
+c11        format('ftn09.',i4.4)
+c         open(9, FILE=ftn09, FORM='FORMATTED')
+
+c             write(9,'(a1)') ' '
+c                    write(9,'(10i5)')
+c     &                  (ilev,ilev=5,nlev,5)
+c             write(9,'(a1)') ' '
+             
+c             do ibox=1,ncol
+c               write(9,'(40(a1),1x,40(a1))')
+c     &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev) 
+c     &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev) 
+c             end do
+c            close(9)
+c
+cIM
+c             if (ncolprint.ne.0) then
+c               write(6,'(a1)') ' '
+c                    write(6,'(a2,1X,5(a7,1X),a50)') 
+c     &                  'ilev',
+c     &                  'pfull','at',
+c     &                  'cc*100','dem_s','dtau_s',
+c     &                  '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
+c               write (6,'(a)') 'skt(j):'
+c               write (6,'(8f7.2)') skt(j)
+                                      
+c               write (6,'(8I7)') (ibox,ibox=1,ncolprint)
+	      
+c               write (6,'(a)') 'tau:'
+c               write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+    
+c               write (6,'(a)') 'tb:'
+c               write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+    
+c               write (6,'(a)') 'ptop:'
+c               write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
+c             endif 
+    
+c        enddo
+       
+c      end if 
+
+      return
+      end 
Index: LMDZ4/tags/LF_20080728/libf/phytherm/lnblnk1.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/lnblnk1.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/lnblnk1.F	(revision 984)
@@ -0,0 +1,47 @@
+!
+! $Header$
+!
+      INTEGER FUNCTION lnblnk1 (letter)
+
+C--------------------------------------------------------
+C Fonction qui determine la longeur d'un string sans les
+C blancs qui suivent. Le critere pour determiner la fin du
+C string est, trois blancs de suite
+C---------------------------------------------------------
+C     ARGUMENTS
+C     +++++++++
+C     letter: CHARACTER*xxx (xxx < imax)
+C             le string dont on determine la longuer
+C     lnblnk1: INTEGER
+C             le nombre de characteres
+C
+C     PARAMETER
+C     +++++++++
+C     imax : INTEGER
+C            le nombre maximale de character que peut contenir le string
+C            a traiter
+
+      IMPLICIT NONE
+      INTEGER i,imax
+      PARAMETER (imax = 256)
+c     CHARACTER*256 letter
+      CHARACTER*4 letter
+
+      i=0
+
+10    i=i+1
+c     IF (letter(i:i+1) . EQ . ' ') THEN
+      IF (letter(i:i) . EQ . ' ') THEN
+c      print*,'i=',i,'letter(i:i+1)=',letter(i:i+1)
+c      print*,'i=',i
+       GOTO 20
+      ELSE
+       GOTO 10
+      ENDIF
+
+20    lnblnk1=i-1
+c     PRINT*,'lnblnk1=',lnblnk1
+
+      RETURN
+      END
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/minmaxqfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/minmaxqfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/minmaxqfi.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+      CHARACTER*(*) comment
+      real qmin,qmax
+      real zq(klon,klev)
+
+      INTEGER jadrs(klon), jbad, k, i
+
+      DO k = 1, klev
+         jbad = 0
+         DO i = 1, klon
+         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+         IF (jbad.GT.0) THEN
+         PRINT*, comment
+         DO i = 1, jbad
+            PRINT*, "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
+         ENDDO
+         ENDIF
+      ENDDO
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_grid_phy_lmdz.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_grid_phy_lmdz.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_grid_phy_lmdz.F90	(revision 984)
@@ -0,0 +1,447 @@
+!
+!$Header$
+!
+MODULE mod_grid_phy_lmdz
+  INTEGER :: nbp_lon  ! == iim
+  INTEGER :: nbp_lat  ! == jjmp1
+  INTEGER :: nbp_lev  ! == llm
+  INTEGER :: 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
+
+END MODULE mod_grid_phy_lmdz
+
+
+  
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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)
+    USE mod_grid_phy_lmdz
+    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   
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_mpi_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_mpi_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_mpi_data.F90	(revision 984)
@@ -0,0 +1,199 @@
+!
+!$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_ok_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_PARA
+    is_ok_mpi=.TRUE.
+#else
+    is_ok_mpi=.FALSE.
+#endif
+    
+    klon_glo=iim*(jjp1-2)+2
+    
+    COMM_LMDZ_PHY=COMM_LMDZ
+
+    IF (is_ok_mpi) THEN    
+#ifdef CPP_PARA
+      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
+  
+  
+    PRINT *, 'ii_begin =', ii_begin
+    PRINT *, 'ii_end =', ii_end
+    PRINT *, 'jj_begin =',jj_begin
+    PRINT *, 'jj_end =', jj_end
+    PRINT *, 'jj_nb =', jj_nb
+    PRINT *, 'ij_begin =', ij_begin
+    PRINT *, 'ij_end =', ij_end
+    PRINT *, 'ij_nb =', ij_nb
+    PRINT *, 'klon_mpi_begin =', klon_mpi_begin
+    PRINT *, 'klon_mpi_end =', klon_mpi_end
+    PRINT *, 'klon_mpi =', klon_mpi
+    PRINT *, 'jj_para_nb =', jj_para_nb
+    PRINT *, 'jj_para_begin =', jj_para_begin
+    PRINT *, 'jj_para_end =', jj_para_end
+    PRINT *, 'ii_para_begin =', ii_para_begin
+    PRINT *, 'ii_para_end =', ii_para_end
+    PRINT *, 'ij_para_nb =', ij_para_nb
+    PRINT *, 'ij_para_begin =', ij_para_begin
+    PRINT *, 'ij_para_end =', ij_para_end
+    PRINT *, 'klon_mpi_para_nb =', klon_mpi_para_nb
+    PRINT *, 'klon_mpi_para_begin =', klon_mpi_para_begin
+    PRINT *, 'klon_mpi_para_end  =', klon_mpi_para_end 
+    PRINT *, 'mpi_rank =', mpi_rank
+    PRINT *, 'mpi_size =', mpi_size
+    PRINT *, 'mpi_root =', mpi_root
+    PRINT *, 'is_mpi_root =', is_mpi_root
+    PRINT *, 'is_north_pole =', is_north_pole
+    PRINT *, 'is_south_pole =', is_south_pole
+    PRINT *, 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_mpi_transfert.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_mpi_transfert.F90	(revision 984)
@@ -0,0 +1,2444 @@
+!
+!$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
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+
+    CALL bcast_mpi_cgen(Var1,len(Var1))
+  END SUBROUTINE bcast_mpi_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_mpi_i(var1)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var1
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var1,1)
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_igen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,1)
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_rgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,1)
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    CALL bcast_mpi_lgen(Var,size(Var))
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+#ifndef CPP_PARA
+    RETURN
+#endif
+    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
+
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+     IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,1)
+     ELSE
+      CALL scatter_mpi_igen(dummy,Varout,1)
+    ENDIF
+    
+  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
+    
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2))
+    ENDIF
+    
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,1)
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,1)
+    ENDIF
+    
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2))      
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+    IF (is_mpi_root) THEN
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ELSE
+      CALL scatter_mpi_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,1)
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,1)      
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3))
+    ENDIF
+  
+  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
+    
+    LOGICAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    ELSE
+      CALL gather_mpi_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))      
+    ENDIF
+  
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+	INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+  
+ 
+  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
+
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+ 
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,2),size(VarOut,3),size(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL grid2dTo1d_glo(VarIn,Var_tmp)
+        CALL scatter_mpi(Var_tmp,VarOut)
+      END SUBROUTINE body
+ 
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        INTEGER,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        INTEGER,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        REAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        REAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        REAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1)
+        LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1
+	
+        LOGICAL,DIMENSION(klon_glo,s1) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5))
+  
+    CONTAINS 
+      SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+        LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+        LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+        INTEGER,INTENT(IN) :: s1,s2,s3
+	
+        LOGICAL,DIMENSION(klon_glo,s1,s2,s3) :: Var_tmp
+        
+        CALL gather_mpi(VarIn,Var_tmp)
+        CALL grid1dTo2d_glo(Var_tmp,VarOut)
+      END SUBROUTINE body
+
+  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 :: dummy
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    INTEGER :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_igen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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 :: dummy
+    
+#ifndef CPP_PARA
+    VarOut=VarIn
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,1)
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,1)
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:)=VarIn(:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:)=VarIn(:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:)=VarIn(:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+    
+    REAL :: dummy
+    
+#ifndef CPP_PARA
+    VarOut(:,:,:,:)=VarIn(:,:,:,:)
+    RETURN
+#endif
+
+    IF (is_mpi_root) THEN
+      CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+    ELSE
+      CALL reduce_sum_mpi_rgen(VarIn,dummy,SIZE(VarIn))      
+    ENDIF
+  
+  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
+
+
+                            
+END MODULE mod_phys_lmdz_mpi_transfert
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+    
+#ifdef CPP_PARA
+    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,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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
+    
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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
+    
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_ok_mpi) RETURN
+
+#ifdef CPP_PARA
+    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_PARA
+    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_ok_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_PARA 
+    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_PARA
+    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_ok_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_PARA 
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    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_ok_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+#ifdef CPP_PARA
+    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_PARA
+    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_ok_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_PARA
+    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_PARA
+    INCLUDE 'mpif.h'
+#endif
+   
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+   
+    IF (.not.is_ok_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+#ifdef CPP_PARA
+    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_PARA
+    INCLUDE 'mpif.h'
+#endif
+    
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+ 
+    IF (.not.is_ok_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+#ifdef CPP_PARA
+    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   
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_omp_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_omp_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_omp_data.F90	(revision 984)
@@ -0,0 +1,104 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_data
+
+  INTEGER,SAVE :: omp_size
+  INTEGER,SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_ok_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
+
+#ifdef _OPENMP    
+    INTEGER :: OMP_GET_NUM_THREADS
+    EXTERNAL OMP_GET_NUM_THREADS
+    INTEGER :: OMP_GET_THREAD_NUM
+    EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef _OPENMP
+!$OMP MASTER
+        is_ok_omp=.TRUE.
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+    is_ok_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
+     PRINT *,'ANORMAL : OMP_MASTER /= 0'
+     STOP
+   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
+
+!$OMP CRITICAL  
+  PRINT *,'--------> TASK ',omp_rank
+  PRINT *,'omp_size =',omp_size
+  PRINT *,'omp_rank =',omp_rank
+  PRINT *,'is_omp_root =',is_omp_root
+  PRINT *,'klon_omp_para_nb =',klon_omp_para_nb
+  PRINT *,'klon_omp_para_begin =',klon_omp_para_begin
+  PRINT *,'klon_omp_para_end =',klon_omp_para_end    
+  PRINT *,'klon_omp =',klon_omp
+  PRINT *,'klon_omp_begin =',klon_omp_begin
+  PRINT *,'klon_omp_end =',klon_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE Print_module_data
+END MODULE mod_phys_lmdz_omp_data
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_omp_transfert.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_omp_transfert.F90	(revision 984)
@@ -0,0 +1,1105 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  INTEGER,PARAMETER :: omp_buffer_size = 1024*1024*16
+  INTEGER,SAVE,DIMENSION(omp_buffer_size) :: omp_buffer
+  
+  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 
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 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),omp_buffer)
+    
+  END SUBROUTINE bcast_omp_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_omp_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_igen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_i
+
+
+  SUBROUTINE bcast_omp_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i1
+
+
+  SUBROUTINE bcast_omp_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i2
+
+
+  SUBROUTINE bcast_omp_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i3
+
+
+  SUBROUTINE bcast_omp_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_rgen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_r
+
+
+  SUBROUTINE bcast_omp_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r1
+
+
+  SUBROUTINE bcast_omp_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r2
+
+
+  SUBROUTINE bcast_omp_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_igen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r3
+
+
+  SUBROUTINE bcast_omp_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_rgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_r4
+
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+
+    CALL bcast_omp_lgen(Var,1,omp_buffer)
+
+  END SUBROUTINE bcast_omp_l
+
+
+  SUBROUTINE bcast_omp_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l1
+
+
+  SUBROUTINE bcast_omp_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l2
+
+
+  SUBROUTINE bcast_omp_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l3
+
+
+  SUBROUTINE bcast_omp_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_omp_lgen(Var,size(Var),omp_buffer)
+
+  END SUBROUTINE bcast_omp_l4
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_igen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_i
+
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_i1
+  
+  
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_i2
+
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_igen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_i3
+
+
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_rgen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_r
+
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_r1
+  
+  
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_r2
+
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_rgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_r3
+  
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL scatter_omp_lgen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_l
+
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE scatter_omp_l1
+  
+  
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3),omp_buffer)
+    ENDIF
+
+  END SUBROUTINE scatter_omp_l2
+
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+    
+    IF (is_omp_root) THEN
+      CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ELSE
+      CALL scatter_omp_lgen(dummy,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),omp_buffer)
+    ENDIF
+  
+  END SUBROUTINE scatter_omp_l3  
+  
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_igen(dummy,Varout,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i2
+  
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_igen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_i3
+
+
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_rgen(VarIn,dummy,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_rgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_r3
+
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL :: dummy
+
+
+     IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,1,omp_buffer)
+     ELSE
+      CALL gather_omp_lgen(VarIn,dummy,1,omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l2
+  
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_omp_data, ONLY : is_omp_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL :: dummy
+
+    IF (is_omp_root) THEN
+      CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ELSE
+      CALL gather_omp_lgen(VarIn,dummy,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),omp_buffer)
+    ENDIF
+    
+  END SUBROUTINE gather_omp_l3
+
+
+
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    CALL reduce_sum_omp_igen(VarIn,Varout,1,omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+   
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    CALL reduce_sum_omp_rgen(VarIn,Varout,1,omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+   
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  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 reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),omp_buffer)
+  
+  END SUBROUTINE reduce_sum_omp_r4
+
+
+
+END MODULE mod_phys_lmdz_omp_transfert
+
+
+
+
+
+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,DIMENSION(Nb),INTENT(INOUT) :: Var
+  INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
+    
+  REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
+    
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+  LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  INTEGER,INTENT(IN) :: Nb
+
+  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
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_para.F90	(revision 984)
@@ -0,0 +1,106 @@
+!
+!$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
+  
+!$OMP THREADPRIVATE(klon_loc)
+  
+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
+    CALL Test_transfert
+!$OMP END PARALLEL    
+     IF (is_ok_mpi .OR. is_ok_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
+  
+    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)
+      PRINT *, "------> 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)
+      PRINT *, "------> 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)
+      PRINT *, "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+     
+   END SUBROUTINE Test_transfert
+  
+END MODULE mod_phys_lmdz_para
+    
Index: LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_transfert_para.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_transfert_para.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/mod_phys_lmdz_transfert_para.F90	(revision 984)
@@ -0,0 +1,1661 @@
+!
+!$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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER
+        CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+        CALL scatter_omp(Var_tmp,Varout)
+    END SUBROUTINE body
+    
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+
+    CALL body(VarIn,VarOut,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+!$OMP MASTER    
+      CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      LOGICAL,DIMENSION(klon_mpi,s1) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      LOGICAL,DIMENSION(klon_mpi,s1,s2) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      LOGICAL,DIMENSION(klon_mpi,s1,s2,s3) :: Var_tmp
+      
+      CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+      CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+    END SUBROUTINE body
+
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      INTEGER,DIMENSION(s1) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      INTEGER,DIMENSION(s1,s2) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      INTEGER,DIMENSION(s1,s2,s3) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3,s4)
+      INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3,s4
+      INTEGER,DIMENSION(s1,s2,s3,s4) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+   
+  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
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1)
+      REAL,INTENT(IN),DIMENSION(:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+      INTEGER,INTENT(IN) :: s1
+      REAL,DIMENSION(s1) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2)
+      REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2
+      REAL,DIMENSION(s1,s2) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3)
+      REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3
+      REAL,DIMENSION(s1,s2,s3) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+  
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL body(VarIn,VarOut,SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))
+    
+  CONTAINS
+    SUBROUTINE body(VarIn,VarOut,s1,s2,s3,s4)
+      REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+      REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+      INTEGER,INTENT(IN) :: s1,s2,s3,s4
+      REAL,DIMENSION(s1,s2,s3,s4) :: Var_tmp
+      
+      CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+      CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+
+    END SUBROUTINE body
+   
+  END SUBROUTINE reduce_sum_r4  
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/moy_undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/moy_undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/moy_undefSTD.F	(revision 984)
@@ -0,0 +1,83 @@
+!
+! $Header$
+!
+      SUBROUTINE moy_undefSTD(nlevSTD,itap,
+     $           dtime,ecrit_day,ecrit_mth,ecrit_hf2mth,
+     $           tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Moyenne - a des frequences differentes - des valeurs bien definies
+c         (.NE.1.E+20) des variables interpolees a un niveau de
+c         pression.
+c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
+c    tous les pas de temps de la physique
+c
+c 2) les variables de type "NMC" (nout=3) sont calculees a partir
+c    des valeurs instantannees toutes les 6 heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c
+c variables Input
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime, ecrit_day, ecrit_mth, ecrit_hf2mth
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+c
+c variables Output
+      REAL tnondef(klon,klevSTD,nout)
+      REAL tsumSTD(klon,klevSTD,nout)
+c
+c calcul 1 fois par jour
+c
+      IF(MOD(itap,NINT(ecrit_day/dtime)).EQ.0) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,1).NE.(ecrit_day/dtime)) THEN
+          tsumSTD(i,k,1)=tsumSTD(i,k,1)/
+     $    (ecrit_day/dtime-tnondef(i,k,1))
+         ELSE
+          tsumSTD(i,k,1)=1.E+20
+         ENDIF !tnondef
+        ENDDO !i
+       ENDDO !k
+      ENDIF !MOD(itap,ecrit_day).EQ.0
+c
+c calcul 1 fois par mois
+c
+      IF(MOD(itap,NINT(ecrit_mth/dtime)).EQ.0) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,2).NE.ecrit_mth/dtime) THEN
+          tsumSTD(i,k,2)=tsumSTD(i,k,2)/
+     $    (ecrit_mth/dtime-tnondef(i,k,2))
+         ELSE
+          tsumSTD(i,k,2)=1.E+20
+         ENDIF !tnondef
+c
+         IF(tnondef(i,k,3).NE.NINT(ecrit_hf2mth)) THEN
+          tsumSTD(i,k,3)=tsumSTD(i,k,3)/
+     $    (ecrit_hf2mth-tnondef(i,k,3))
+         ELSE
+          tsumSTD(i,k,3)=1.E+20
+         ENDIF !tnondef
+c
+        ENDDO !i
+       ENDDO !k
+      ENDIF !MOD
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phytherm/moyglo_aire.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/moyglo_aire.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/moyglo_aire.F	(revision 984)
@@ -0,0 +1,161 @@
+!
+! $Header$
+!
+      SUBROUTINE moyglo_pondaire(nhori, champ, aire, 
+     .            ok_msk, msk, moyglo)
+c
+       USE dimphy
+       IMPLICIT none
+c
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
+c
+c moyenne = Somme_(champ* aire)/Somme_aire
+c
+c ==================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+       INTEGER i, nhori
+       REAL champ(klon), aire(klon), msk(klon)
+       LOGICAL ok_msk 
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaire nhori',nhori
+c
+       airetot=0.
+       moyglo=0.
+c
+       IF(ok_msk) THEN
+        DO i=1, nhori
+c        IF(msk(i).EQ.1.) THEN 
+         IF(msk(i).GT.0.) THEN 
+c
+c aire totale
+          airetot=airetot+aire(i)*msk(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i)*msk(i) 
+         ENDIF
+        ENDDO
+c
+       ELSE !ok_msk
+        DO i=1, nhori
+c
+c aire totale
+          airetot=airetot+aire(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i) 
+        ENDDO 
+c
+       ENDIF
+c 
+c moyenne ponderee par l'aire
+       moyglo=moyglo/airetot
+c
+       RETURN 
+       END
+c
+       SUBROUTINE moyglo_pondaima(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
+c totale avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_aire
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c aire totale
+       airetot=0.
+       DO i=1, nhori
+        airetot=airetot+aire(i)
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/airetot
+c
+      RETURN
+      END
+c
+       SUBROUTINE moyglo_pondmass(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par la
+c masse totale d'air, avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL massetot
+c
+c      PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c masse totale
+       massetot=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        massetot=massetot+
+     .  (pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/massetot
+c
+      RETURN
+      END
+c
Index: LMDZ4/tags/LF_20080728/libf/phytherm/newmicro.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/newmicro.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/newmicro.F	(revision 984)
@@ -0,0 +1,364 @@
+!
+! $Header$
+!
+      SUBROUTINE newmicro (paprs, pplay,ok_newmicro,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     s                  xflwp, xfiwp, xflwc, xfiwc,
+     e                  ok_aie, 
+     e                  sulfate, sulfate_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c 
+c ok_aie--input-L-apply aerosol indirect effect or not
+c sulfate-input-R-sulfate aerosol mass concentration [um/m^3]
+c sulfate_pi-input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell           
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "nuage.h"
+cIM cf. CR: include pour NOVLP et ZEPSEC
+#include "radepsi.h"
+#include "radopt.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+cIM: 091003   REAL zflwp, zradef, zfice, zmsac
+      REAL zflwp(klon), zradef, zfice, zmsac
+cIM: 091003 rajout
+      REAL xflwp(klon), xfiwp(klon)
+      REAL xflwc(klon,klev), xfiwc(klon,klev)
+c
+      REAL radius, rad_chaud
+cc      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+ccc      PARAMETER (nexpo=1)
+
+c -- sb:
+      logical ok_newmicro
+c     parameter (ok_newmicro=.FALSE.)
+cIM: 091003   real rel, tc, rei, zfiwp
+      real rel, tc, rei, zfiwp(klon)
+      real k_liq, k_ice0, k_ice, DF
+      parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g
+      parameter (DF=1.66) ! diffusivity factor
+c sb --
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      LOGICAL ok_a1lwpdep       ! a1 LWP dependent?
+      
+      REAL sulfate(klon, klev)  ! sulfate aerosol mass concentration [ug m-3]
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL sulfate_pi(klon, klev)  ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value)
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)       ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end    
+cIM cf. CR:parametres supplementaires
+      REAL zclear(klon)
+      REAL zcloud(klon) 
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+cIM inversion des DO
+      DO i = 1, klon
+       xflwp(i)=0.
+       xfiwp(i)=0.
+cccccccccccc!CDIR NOVECTOR
+      DO k = 1, klev
+c
+       xflwc(i,k)=0.
+       xfiwc(i,k)=0.
+c
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp(i) = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp(i) / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp(i))
+
+         if (ok_newmicro) then
+
+c -- liquid/ice cloud water paths:
+
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+
+         zflwp(i) = 1000.*(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         zfiwp(i) = 1000.*zfice*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+         xflwp(i) = xflwp(i)+ (1.-zfice)*pqlwp(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         xfiwp(i) = xfiwp(i)+ zfice*pqlwp(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+cIM Total Liquid/Ice water content
+         xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)
+         xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)
+cIM In-Cloud Liquid/Ice water content
+c        xflwc(i,k) = xflwc(i,k)+(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+c        xfiwc(i,k) = xfiwc(i,k)+zfice*pqlwp(i,k)/pclc(i,k)
+
+c -- effective cloud droplet radius (microns):
+
+c for liquid water clouds: 
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            !
+            !
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+c           rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            rad_chaud = MAX(rad_chaud*1.e6, 5.) 
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc_pi(i,k)) )**(1./3.)
+            radius = MAX(radius*1.e6, 5.) 
+            
+            tc = t(i,k)-273.15
+            rei = 0.71*tc + 61.29 
+            if (tc.le.-81.4) rei = 3.5 
+            if (zflwp(i).eq.0.) radius = 1. 
+            if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. 
+            cldtaupi(i,k) = 3.0/2.0 * zflwp(i) / radius
+     .             + zfiwp(i) * (3.448e-03  + 2.431/rei)
+         ENDIF                  ! ok_aie
+         ! For output diagnostics
+         !
+         ! Cloud droplet effective radius [um]
+         !
+         ! we multiply here with f * xl (fraction of liquid water
+         ! clouds in the grid cell) to avoid problems in the
+         ! averaging of the output.
+         ! In the output of IOIPSL, derive the real cloud droplet 
+         ! effective radius as re/fl
+         !
+         fl(i,k) = pclc(i,k)*(1.-zfice)            
+         re(i,k) = rad_chaud*fl(i,k)
+            
+c-jq end         
+         
+         rel = rad_chaud
+c for ice clouds: as a function of the ambiant temperature
+c [formula used by Iacobellis and Somerville (2000), with an 
+c asymptotical value of 3.5 microns at T<-81.4 C added to be 
+c consistent with observations of Heymsfield et al. 1986]:
+         tc = t(i,k)-273.15
+         rei = 0.71*tc + 61.29 
+         if (tc.le.-81.4) rei = 3.5 
+
+c -- cloud optical thickness :
+
+c [for liquid clouds, traditional formula, 
+c  for ice clouds, Ebert & Curry (1992)] 
+
+         if (zflwp(i).eq.0.) rel = 1. 
+         if (zfiwp(i).eq.0. .or. rei.le.0.) rei = 1. 
+         pcltau(i,k) = 3.0/2.0 * ( zflwp(i)/rel )
+     .             + zfiwp(i) * (3.448e-03  + 2.431/rei)
+
+c -- cloud infrared emissivity:
+
+c [the broadband infrared absorption coefficient is parameterized
+c  as a function of the effective cld droplet radius]
+
+c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+         k_ice = k_ice0 + 1.0/rei
+
+         pclemi(i,k) = 1.0
+     .      - EXP( - coef_chau*zflwp(i) - DF*k_ice*zfiwp(i) )
+
+         endif ! ok_newmicro
+
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (lo) cldtaupi(i,k) = 0.0
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+cIM cf. CR:test: calcul prenant ou non en compte le recouvrement
+cinitialisations
+      DO i=1,klon
+         zclear(i)=1.
+         zcloud(i)=0.
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+cIM cf CR DO k=1,klev
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+cIM cf. CR
+            IF (NOVLP.EQ.1) THEN
+               zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               pct(i)=1.-zclear(i) 
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+                  pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then
+                  pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then 
+                  pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     s                            /(1.-MIN(zcloud(i),1.-ZEPSEC))
+               endif
+               zcloud(i)=pclc(i,k)
+            ELSE IF (NOVLP.EQ.2) THEN
+               zcloud(i)=MAX(pclc(i,k),zcloud(i))
+               pct(i)=zcloud(i)
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+                  pch(i) = MIN(pclc(i,k),pch(i))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then
+                  pcm(i) = MIN(pclc(i,k),pcm(i))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then
+                  pcl(i) = MIN(pclc(i,k),pcl(i))
+               endif
+            ELSE IF (NOVLP.EQ.3) THEN
+               zclear(i)=zclear(i)*(1.-pclc(i,k))
+               pct(i)=1-zclear(i)
+               if (pplay(i,k).LE.cetahb*paprs(i,1)) then
+               pch(i) = pch(i)*(1.0-pclc(i,k))
+               else if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .                  pplay(i,k).LE.cetamb*paprs(i,1)) then 
+               pcm(i) = pcm(i)*(1.0-pclc(i,k))
+               else if (pplay(i,k).GT.cetamb*paprs(i,1)) then
+               pcl(i) = pcl(i)*(1.0-pclc(i,k))
+               endif
+            ENDIF
+         ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+cIM cf. CR          pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/nflxtr.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/nflxtr.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/nflxtr.F	(revision 984)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+      SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pplay,paprs,x,dx) 
+      USE dimphy
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant 
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--flux convectifs mais en variables locales
+      REAL zmfu(klon,klev+1) 
+      REAL zmfd(klon,klev+1) 
+      REAL zen_u(klon,klev) 
+      REAL zde_u(klon,klev)
+      REAL zen_d(klon,klev) 
+      REAL zde_d(klon,klev)
+      real zmfe
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+
+c =========================================
+c
+c
+c   Extension des flux UP et DN sur klev+1 niveaux
+c =========================================
+      do k=1,klev
+         do i=1,klon
+            zmfu(i,k)=pmfu(i,k)
+            zmfd(i,k)=pmfd(i,k)
+         enddo
+      enddo
+      do i=1,klon
+         zmfu(i,klev+1)=0.
+         zmfd(i,klev+1)=0.
+      enddo
+
+c--modif pour diagnostiquer les detrainements
+c =========================================
+c   on privilegie l'ajustement de l'entrainement dans l'ascendance.
+
+      do k=1, klev
+         do i=1, klon
+            zen_d(i,k)=pen_d(i,k)
+            zde_u(i,k)=pde_u(i,k)
+            zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
+            zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
+         enddo 
+      enddo 
+c
+c--calcul des flux dans le panache montant
+c =========================================
+c
+c Dans la premiere couche, on prend q comme valeur de qu
+c
+      do i=1, klon
+         zmfux(i,1)=0.0 
+      enddo
+c
+c Autres couches
+      do k=1,klev
+         do i=1, klon
+            if ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
+               xu(i,k)=x(i,k)
+            else
+               xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))
+     s               /(zmfu(i,k+1)+zde_u(i,k))
+            endif
+            zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
+         enddo
+      enddo
+c
+c--calcul des flux dans le panache descendant
+c =========================================
+c   
+      do i=1, klon
+         zmfdx(i,klev+1)=0.0 
+      enddo
+c
+      do k=klev,1,-1
+         do i=1, klon
+            if ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
+               xd(i,k)=x(i,k)
+            else
+               xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k)) /
+     .               (zmfd(i,k)-zde_d(i,k))
+            endif
+            zmfdx(i,k)=zmfd(i,k)*xd(i,k)
+         enddo
+      enddo
+c
+c--introduction du flux de retour dans l'environnement
+c =========================================
+c
+      do k=2, klev
+         do i=1, klon
+            zmfe=-zmfu(i,k)-zmfd(i,k)
+            if (zmfe.le.0.) then
+               zmfex(i,k)= zmfe*x(i,k)
+            else
+               zmfex(i,k)= zmfe*x(i,k-1)
+            endif
+         enddo
+      enddo
+
+      do i=1, klon
+         zmfex(i,1)=0.
+         zmfex(i,klev+1)=0.
+      enddo
+c
+c--calcul final des tendances
+c
+      do k=1, klev
+         do i=1, klon
+            dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*
+     .                      ( zmfux(i,k) - zmfux(i,k+1) +
+     .                        zmfdx(i,k) - zmfdx(i,k+1) +
+     .                        zmfex(i,k) - zmfex(i,k+1) )
+         enddo
+      enddo
+c
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/nonlocal.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/nonlocal.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/nonlocal.F	(revision 984)
@@ -0,0 +1,415 @@
+!
+! $Header$
+!
+C======================================================================
+      SUBROUTINE nonlocal(knon, paprs, pplay,
+     .                    tsol,beta,u,v,t,q,
+     .                    cd_h, cd_m, pcfh, pcfm, cgh, cgq)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+#include "YOMCST.h"
+#include "iniprint.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL tsol(klon) ! temperature du sol (K)
+      REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+      REAL vk
+      PARAMETER (vk=0.40)
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)
+      REAL fakn
+      PARAMETER (fakn=7.2)
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)
+      REAL sffrac
+      PARAMETER (sffrac=0.1)
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL z(klon,klev)
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL ustar(klon)
+      REAL rino(klon,klev)  ! bulk Richardon no. from level to ref lev
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      REAL pblh(klon)
+      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)
+      REAL ztvd, ztvu, zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5, zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation
+c
+      isommet=klev
+
+      DO i = 1, klon
+         pcfh(i,1) = cd_h(i)
+         pcfm(i,1) = cd_m(i)
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         pcfh(i,k) = zkmin
+         pcfm(i,k) = zkmin
+         cgs(i,k) = 0.0
+         cgh(i,k) = 0.0
+         cgq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+      ENDDO
+      ENDDO
+c
+      DO i = 1, knon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+           zxqs=MIN(0.5,zxqs)
+           zcor=1./(1.-retv*zxqs)
+           zxqs=zxqs*zcor
+         ELSE
+           IF (tsol(i).LT.t_coup) THEN
+              zxqs = qsats(tsol(i)) / paprs(i,1)
+           ELSE
+              zxqs = qsatl(tsol(i)) / paprs(i,1)
+           ENDIF
+         ENDIF
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .        *(1.+RETV*q(i,1))*zx_alf1
+     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+     .        *(1.+RETV*q(i,2))*zx_alf2
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+      ENDDO
+c
+      DO i = 1, knon
+         rino(i,1) = 0.0
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+      ENDDO
+
+C
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C
+      fac = 100.0
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+        wm(i)= ustar(i)*phiminv(i)
+        therm(i) = heatv(i)*fak/wm(i)
+        rino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+C Improve pblh estimate for unstable conditions using the
+C convective temperature excess:
+C
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Points for which pblh exceeds number of pbl layers allowed;
+C set to maximum
+C
+      DO i = 1, knon
+        IF (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+      ENDDO
+C
+C pblh is now available; do preparation for diffusivity calculation:
+C
+      DO i = 1, knon
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C
+        IF (unstbl(i)) THEN
+          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+C
+C For all unstable layers, set diffusivities
+C
+        DO i = 1, knon
+        IF (unslev(i)) THEN
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pblk(i)/pr(i)
+        ENDIF
+        ENDDO
+ 1000 continue           ! end of level loop
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/nuage.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/nuage.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/nuage.F	(revision 984)
@@ -0,0 +1,409 @@
+!
+! $Header$
+!
+      SUBROUTINE nuage (paprs, pplay,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     e                  ok_aie,
+     e                  sulfate, sulfate_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c ok_aie--input-L-apply aerosol indirect effect or not
+c sulfate-input-R-sulfate aerosol mass concentration [um/m^3]
+c sulfate_pi-input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell      
+c 
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+c
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+      
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      
+      REAL sulfate(klon, klev)  ! sulfate aerosol mass concentration [ug m-3]
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL sulfate_pi(klon, klev)  ! sulfate aerosol mass concentration [ug m-3] (pre-industrial value)
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)  ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end      
+      
+ccc      PARAMETER (nexpo=1)
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+            
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(sulfate_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+            rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            
+            ! For output diagnostics
+            !
+            ! Cloud droplet effective radius [um]
+            !
+            ! we multiply here with f * xl (fraction of liquid water
+            ! clouds in the grid cell) to avoid problems in the
+            ! averaging of the output.
+            ! In the output of IOIPSL, derive the real cloud droplet 
+            ! effective radius as re/fl
+            !
+            fl(i,k) = pclc(i,k)*(1.-zfice)            
+            re(i,k) = rad_chaud*fl(i,k)
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k)))  
+     .                / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.), 
+     .               3.) * (1.-zfice) + rad_froid * zfice           
+            cldtaupi(i,k) = 3.0/2.0 * zflwp / radius
+     .           
+         ENDIF                  ! ok_aie
+         
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))
+     .      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .       pplay(i,k).LE.cetamb*paprs(i,1)) 
+     .      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))
+     .      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,
+     .                   diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+c Laurent Li (LMD/CNRS), le 12 octobre 1998
+c                        (adaptation du code ECMWF)
+c
+c Dans certains cas, le schema pronostique des nuages n'est
+c pas suffisament performant. On a donc besoin de diagnostiquer
+c ces nuages. Je dois avouer que c'est une frustration.
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+c
+c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon ! pour traiter les enclumes
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.
+     .    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))
+     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
+     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+c
+c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))
+     .          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.
+     .       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)
+     .   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/nuage.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/nuage.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/nuage.h	(revision 984)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      REAL rad_froid, rad_chau1, rad_chau2
+
+      common /nuagecom/ rad_froid,rad_chau1, rad_chau2
+!$OMP THREADPRIVATE(/nuagecom/)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/o3cm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/o3cm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/o3cm.F	(revision 984)
@@ -0,0 +1,61 @@
+!
+! $Header$
+!
+      SUBROUTINE o3cm (amb, bmb, sortie, ntab)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ce programme calcule le contenu en ozone "sortie"
+c        (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb)
+c        "ntab" est le nombre d'intervalles pour l'integration, sa
+c        valeur depend bien sur de l'epaisseur de la couche et de
+c        la precision qu'on souhaite a obtenir
+c======================================================================
+      REAL amb, bmb, sortie
+      INTEGER ntab
+c======================================================================
+      INTEGER n
+      REAL xtab(500), xa, xb, ya, yb, xincr
+c======================================================================
+      external mbtozm
+c======================================================================
+c la fonction en ligne w(x) donne le profil de l'ozone en fonction
+c de l'altitude (unite: cm.atm / km)
+c (Green 1964, Appl. Opt. 3: 203-208)
+      REAL wp, xp, h, x, w, con
+      PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0)
+      w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2
+c======================================================================
+      IF (ntab .GT. 499) STOP 'BIG ntab'
+      xincr = (bmb-amb) / FLOAT(ntab)
+      xtab(1) = amb
+      DO n = 2, ntab
+         xtab(n) = xtab(n-1) + xincr
+      ENDDO
+      xtab(ntab+1) = bmb
+      sortie = 0.0
+      DO n = 1, ntab
+         CALL mbtozm(xtab(n), xa)
+         CALL mbtozm(xtab(n+1), xb)
+         xa = xa / 1000.
+         xb = xb / 1000.
+         ya = w(xa)
+         yb = w(xb)
+         sortie = sortie + (ya+yb)/2.0 * ABS(xb-xa)
+      ENDDO
+      RETURN
+      END
+      SUBROUTINE mbtozm(rmb,zm)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Objet: transformer une hauteur de mb (rmb) en metre (zm)
+c======================================================================
+      REAL rmb, zm
+c======================================================================
+      REAL gama, tzero, pzero, g, r
+      PARAMETER (gama=6.5e-3, tzero=288., pzero=1013.25)
+      PARAMETER (g=9.81, r=287.0)
+      zm = tzero/gama * ( 1.-(rmb/pzero)**(r*gama/g) )
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/oasis.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/oasis.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/oasis.F90	(revision 984)
@@ -0,0 +1,396 @@
+!
+! $Header$
+!
+MODULE oasis
+!
+! This module contains subroutines for initialization, sending and receiving 
+! towards the coupler OASIS3. It also contains some parameters for the coupling.
+!
+! This module should always be compiled. With the coupler OASIS3 available the cpp key
+! CPP_COUPLE should be set and the entier of this file will then be compiled. 
+! In a forced mode CPP_COUPLE should not be defined and the compilation ends before 
+! the CONTAINS, without compiling the subroutines.
+!
+  USE dimphy 
+  USE mod_phys_lmdz_para
+  USE write_field_phy
+
+#ifdef CPP_COUPLE
+  USE mod_prism_proto
+  USE mod_prism_def_partition_proto
+  USE mod_prism_get_proto
+  USE mod_prism_put_proto
+#endif
+  
+  IMPLICIT NONE
+    
+! Maximum number of fields exchanged between ocean and atmosphere
+  INTEGER, PARAMETER  :: jpmaxfld=40
+! Number of fields exchanged from atmosphere to ocean via flx.F
+  INTEGER, PARAMETER  :: jpflda2o1=13
+! Number of fields exchanged from atmosphere to ocean via tau.F
+  INTEGER, PARAMETER  :: jpflda2o2=6
+! Number of fields exchanged from ocean to atmosphere
+  INTEGER, PARAMETER  :: jpfldo2a=4
+
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_read
+  !$OMP THREADPRIVATE(cl_read)
+  CHARACTER (len=8), DIMENSION(jpmaxfld), PUBLIC, SAVE   :: cl_writ
+  !$OMP THREADPRIVATE(cl_writ)
+
+  INTEGER, DIMENSION(jpfldo2a), SAVE, PRIVATE            :: in_var_id
+  !$OMP THREADPRIVATE(in_var_id)
+  INTEGER, DIMENSION(jpflda2o1+jpflda2o2), SAVE, PRIVATE :: out_var_id
+  !$OMP THREADPRIVATE(out_var_id)
+
+
+#ifdef CPP_COUPLE
+
+CONTAINS
+
+  SUBROUTINE inicma
+!************************************************************************************
+!**** *INICMA*  - Initialize coupled mode communication for atmosphere
+!                 and exchange some initial information with Oasis
+!
+!     Rewrite to take the PRISM/psmile library into account
+!     LF 09/2003
+!
+    INCLUDE "dimensions.h"
+
+! Local variables
+!************************************************************************************
+    INTEGER                            :: comp_id
+    INTEGER                            :: ierror, il_commlocal
+    INTEGER                            :: il_part_id
+    INTEGER, DIMENSION(3)              :: ig_paral
+    INTEGER, DIMENSION(2)              :: il_var_nodims
+    INTEGER, DIMENSION(4)              :: il_var_actual_shape
+    INTEGER                            :: il_var_type
+    INTEGER                            :: nuout = 6
+    INTEGER                            :: jf
+    CHARACTER (len = 6)                :: clmodnam
+    CHARACTER (len = 20)               :: modname = 'inicma'
+    CHARACTER (len = 80)               :: abort_message 
+
+!*    1. Initializations
+!        ---------------
+!************************************************************************************
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' ROUTINE INICMA'
+    WRITE(nuout,*) ' **************'
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) ' '
+
+!
+! Define the model name
+!
+    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+!
+!************************************************************************************
+! Here we go: psmile initialisation
+!************************************************************************************
+    IF (is_sequential) THEN
+       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
+       
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_init_comp '
+          CALL abort_gcm(modname,abort_message,1)
+       ELSE
+          WRITE(nuout,*) 'inicma : init psmile ok '
+       ENDIF
+    ENDIF
+
+    CALL prism_get_localcomm_proto (il_commlocal, ierror)
+!************************************************************************************
+! Domain decomposition
+!************************************************************************************
+    ig_paral(1) = 1                            ! apple partition for //
+    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
+    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
+
+    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
+    WRITE(nuout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
+    
+    ierror=PRISM_Ok
+    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
+
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme dans prism_def_partition '
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : decomposition domaine psmile ok '
+    ENDIF
+
+!************************************************************************************
+! Field Declarations
+!************************************************************************************
+!     Define symbolic name for fields exchanged from atmos to coupler,
+!         must be the same as (1) of the field  definition in namcouple:
+    cl_writ(1)='COTAUXXU'
+    cl_writ(2)='COTAUYYU'
+    cl_writ(3)='COTAUZZU'
+    cl_writ(4)='COTAUXXV'
+    cl_writ(5)='COTAUYYV'
+    cl_writ(6)='COTAUZZV'
+    cl_writ(7)='COWINDSP'
+    cl_writ(8)='COSHFICE'
+    cl_writ(9)='COSHFOCE'
+    cl_writ(10)='CONSFICE'
+    cl_writ(11)='CONSFOCE'
+    cl_writ(12)='CODFLXDT'
+    cl_writ(13)='COTFSICE'
+    cl_writ(14)='COTFSOCE'
+    cl_writ(15)='COTOLPSU'
+    cl_writ(16)='COTOSPSU'
+    cl_writ(17)='CORUNCOA'
+    cl_writ(18)='CORIVFLU'
+    cl_writ(19)='COCALVIN'
+!
+!     Define symbolic name for fields exchanged from coupler to atmosphere,
+!         must be the same as (2) of the field  definition in namcouple:
+!
+    cl_read(1)='SISUTESW'
+    cl_read(2)='SIICECOV'
+    cl_read(3)='SIICEALW'
+    cl_read(4)='SIICTEMW'
+    
+    il_var_nodims(1) = 2
+    il_var_nodims(2) = 1
+
+    il_var_actual_shape(1) = 1
+    il_var_actual_shape(2) = iim
+    il_var_actual_shape(3) = 1
+    il_var_actual_shape(4) = jjm+1
+   
+    il_var_type = PRISM_Real
+
+!************************************************************************************
+! Oceanic Fields
+!************************************************************************************
+    DO jf=1, jpfldo2a
+       CALL prism_def_var_proto(in_var_id(jf), cl_read(jf), il_part_id, &
+            il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! Atmospheric Fields
+!************************************************************************************
+    DO jf=1, jpflda2o1+jpflda2o2
+       CALL prism_def_var_proto(out_var_id(jf), cl_writ(jf), il_part_id, &
+            il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
+            ierror)
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_def_var_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+
+!************************************************************************************
+! End definition
+!************************************************************************************
+    CALL prism_enddef_proto(ierror)
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme init dans prism_ endef_proto'
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(nuout,*) 'inicma : endef psmile ok '
+    ENDIF
+    
+  END SUBROUTINE inicma
+
+!
+!************************************************************************************
+!
+
+  SUBROUTINE fromcpl(ktime, tab_get)
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
+! and Sea-Ice provided by the coupler. Adaptation to psmile library
+!======================================================================
+!
+    INCLUDE "dimensions.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                               ::  ktime
+
+! Output arguments
+!************************************************************************************
+    REAL, DIMENSION(iim, jj_nb,jpfldo2a), INTENT(OUT) :: tab_get
+
+! Local variables
+!************************************************************************************
+    INTEGER                       :: nuout  = 6             ! listing output unit
+    INTEGER                       :: ierror, i
+    INTEGER                       :: istart,iend
+    CHARACTER (len = 20)          :: modname = 'fromcpl'
+    CHARACTER (len = 80)          :: abort_message 
+    REAL, DIMENSION(iim*jj_nb)    :: field
+
+!************************************************************************************
+    WRITE (nuout,*) ' '
+    WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
+    WRITE (nuout,*) ' '
+    CALL flush (nuout)
+    
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    DO i = 1, jpfldo2a
+       field(:) = -99999.
+       CALL prism_get_proto(in_var_id(i), ktime, field(istart:iend), ierror)
+       tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
+            ierror.NE.PRISM_FromRest &
+            .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
+            .AND. ierror.NE.PRISM_FromRestOut) THEN
+          WRITE (nuout,*)  cl_read(i), ktime   
+          abort_message=' Probleme dans prism_get_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+    END DO
+    
+    
+  END SUBROUTINE fromcpl
+
+!
+!************************************************************************************
+! 
+
+  SUBROUTINE intocpl(ktime, last, tab_put) 
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
+! atmospheric coupling fields to the coupler with the psmile library.
+! IF last time step, writes output fields to binary files.
+! ======================================================================
+!
+! 
+    INCLUDE "dimensions.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                                          :: ktime
+    LOGICAL, INTENT(IN)                                          :: last
+    REAL, DIMENSION(iim, jj_nb, jpflda2o1+jpflda2o2), INTENT(IN) :: tab_put
+
+! Local variables
+!************************************************************************************
+    LOGICAL                     :: checkout=.FALSE.
+    INTEGER                     :: istart,iend
+    INTEGER                     :: wstart,wend
+    INTEGER, PARAMETER          :: nuout = 6 
+    INTEGER                     :: ierror, i
+    REAL, DIMENSION(iim*jj_nb)  :: field
+    CHARACTER (len = 20),SAVE   :: modname = 'intocpl'
+    CHARACTER (len = 80)        :: abort_message 
+
+!************************************************************************************
+
+    WRITE(nuout,*) ' '
+    WRITE(nuout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
+    WRITE(nuout,*) 'last  ', last
+    WRITE(nuout,*)
+
+
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    IF (checkout) THEN   
+       wstart=istart
+       wend=iend
+       IF (is_north_pole) wstart=istart+iim-1
+       IF (is_south_pole) wend=iend-iim+1
+       
+       field = RESHAPE(tab_put(:,:,8),(/iim*jj_nb/))
+       CALL writeField_phy("fsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,9),(/iim*jj_nb/))
+       CALL writeField_phy("fsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,10),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,11),(/iim*jj_nb/))
+       CALL writeField_phy("fnsolwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,12),(/iim*jj_nb/))
+       CALL writeField_phy("fnsicedt",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,13),(/iim*jj_nb/))
+       CALL writeField_phy("evice",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,14),(/iim*jj_nb/))
+       CALL writeField_phy("evwat",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,15),(/iim*jj_nb/))
+       CALL writeField_phy("lpre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,16),(/iim*jj_nb/))
+       CALL writeField_phy("spre",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,17),(/iim*jj_nb/))
+       CALL writeField_phy("dirunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,18),(/iim*jj_nb/))
+       CALL writeField_phy("rivrunoff",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,19),(/iim*jj_nb/))
+       CALL writeField_phy("calving",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,1),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,2),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,3),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_u",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,4),(/iim*jj_nb/))
+       CALL writeField_phy("tauxx_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,5),(/iim*jj_nb/))
+       CALL writeField_phy("tauyy_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,6),(/iim*jj_nb/))
+       CALL writeField_phy("tauzz_v",field(wstart:wend),1)
+       field = RESHAPE(tab_put(:,:,7),(/iim*jj_nb/))
+       CALL writeField_phy("windsp",field(wstart:wend),1)
+    ENDIF
+   
+!************************************************************************************
+! PRISM_PUT
+!************************************************************************************
+
+    DO i = 1, jpflda2o1+jpflda2o2
+       field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
+       CALL prism_put_proto(out_var_id(i), ktime, field(istart:iend), ierror)
+       
+       IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
+            .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
+            ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
+          WRITE (nuout,*)  cl_writ(i), ktime   
+          abort_message=' Probleme dans prism_put_proto '
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+    END DO
+   
+!************************************************************************************
+! Finalize PSMILE for the case is_sequential, if parallel finalization is done 
+! from Finalize_parallel in dyn3dpar/parallel.F90
+!************************************************************************************
+
+    IF (last) THEN
+       IF (is_sequential) THEN 
+          CALL prism_terminate_proto(ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             abort_message=' Probleme dans prism_terminate_proto '
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    ENDIF
+    
+    
+  END SUBROUTINE intocpl
+
+#endif
+  
+END MODULE oasis
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ocean_cpl_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ocean_cpl_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ocean_cpl_mod.F90	(revision 984)
@@ -0,0 +1,370 @@
+!
+! $Header$
+!
+MODULE ocean_cpl_mod
+!
+! This module is used both for the sub-surface ocean and sea-ice for the case of a 
+! coupled model configuration, ocean=couple. 
+!
+
+  USE dimphy,           ONLY : klon
+  USE cpl_mod
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE climb_wind_mod,   ONLY : calcul_wind_flux
+
+  IMPLICIT NONE
+  PRIVATE
+
+  PUBLIC :: ocean_cpl_init, ocean_cpl_get_vars, ocean_cpl_noice, ocean_cpl_ice
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_o
+  !$OMP THREADPRIVATE(tmp_flux_o)
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE       :: tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_g)
+
+!****************************************************************************************
+!
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
+!
+! Allocate fields for this module and initailize the module mod_cpl
+!
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
+
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! Initialize module cpl_init
+    CALL cpl_init(dtime, rlon, rlat)
+    
+  END SUBROUTINE ocean_cpl_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_noice( &
+       sollw, albedo, &
+       windsp, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       swdown, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice. The subroutine first receives fields from coupler, then some calculations at 
+! surface is done and finally it sends some fields to the coupler.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+!    
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    INTEGER, DIMENSION(1) :: iloc
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: zx_sl
+    REAL, DIMENSION(klon) :: fder_new
+    REAL, DIMENSION(klon) :: tsurf_cpl
+    REAL, DIMENSION(klon) :: taux, tauy
+    LOGICAL               :: check=.FALSE.
+
+! End definitions
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
+
+!****************************************************************************************
+! Receive sea-surface temperature(tsurf_cpl) and new fraction of ocean surface(pctsrf_oce) 
+! from coupler
+!
+!****************************************************************************************
+    CALL cpl_receive_ocean_fields(itime, dtime, knon, knindex, pctsrf_in, &
+         tsurf_cpl, pctsrf_oce)
+
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    ! Calcultate the flux of u and v at surface
+    CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!****************************************************************************************
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+       !IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+       !       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_ocean_fields(itime, knon, knindex, &
+         swdown, sollw, fluxlat, fluxsens, &
+         precip_rain, precip_snow, evap, tsurf_new, fder_new, albedo, taux, tauy, windsp)
+    
+
+  END SUBROUTINE ocean_cpl_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_ice( &
+       rlon, rlat, sollw, albedo, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       lafin, &
+       swdown, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, pctsrf_in, &
+       radsol, snow, qsurf, &
+       alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. The subroutine first receives 
+! fields from coupler, then some calculations at surface is done and finally sends 
+! some fields to the coupler.
+!    
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf_in
+
+! In/output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                 :: i
+    INTEGER, DIMENSION(1)   :: iloc
+    LOGICAL                 :: check=.FALSE.
+    REAL, PARAMETER         :: t_grnd=271.35
+    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
+    REAL, DIMENSION(klon)   :: taux, tauy
+
+! End definitions
+!****************************************************************************************
+    
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! Receive ocean temperature(tsurf_cpl), albedo(alb_new) and new fraction of 
+! seaice(pctsrf_sic) from coupler
+!
+!****************************************************************************************
+
+    CALL cpl_receive_seaice_fields(knon, knindex, &
+         tsurf_cpl, alb_new, pctsrf_sic)
+    
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    dif_grnd = 0.
+    beta = 1.0
+    
+
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_cpl, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    ! Calcultate the flux of u and v at surface
+    CALL calcul_wind_flux(knon, dtime, taux, tauy)
+    
+!****************************************************************************************
+! Flux ocean-atmosphere useful for "slab" ocean but here calculated only for printing
+! usage later in physiq  
+! 
+!  IM: faire dependre le coefficient de conduction de la glace de mer
+!      de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!      actuel correspond a 3m de glace de mer, cf. L.Li
+!
+!****************************************************************************************
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_sic(knindex(i)) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * &
+            dif_grnd(i) * RCPD/cal(i) 
+    ENDDO
+    
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder ****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf_in, lafin, rlon, rlat, &
+       swdown, sollw, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf_new, fder_new, albedo, taux, tauy)
+ 
+
+    alblw(1:knon) = alb_new(1:knon)    
+
+  END SUBROUTINE ocean_cpl_ice
+!  
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_get_vars(flux_o, flux_g)
+
+! This subroutine returns variables private in this module to an external 
+! routine (physiq).
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Set the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_cpl_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_cpl_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ocean_forced_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ocean_forced_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ocean_forced_mod.F90	(revision 984)
@@ -0,0 +1,365 @@
+!
+! $Header$
+!
+MODULE ocean_forced_mod
+!
+! This module is used for both the sub-surfaces ocean and sea-ice for the case of a 
+! forced ocean,  "ocean=force".
+!
+  USE surface_data,     ONLY : calice, calsno, tau_gl
+  USE fonte_neige_mod,  ONLY : fonte_neige
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE dimphy
+
+  IMPLICIT NONE
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE, PRIVATE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+
+CONTAINS
+!
+!****************************************************************************************
+! 
+  SUBROUTINE ocean_forced_init
+! Allocate fields needed for this module
+!    
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_forced_init'
+!****************************************************************************************
+
+    ALLOCATE(tmp_flux_o(1:klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_g(1:klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF    
+
+
+  END SUBROUTINE ocean_forced_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_noice(itime, dtime, jour, knon, knindex, &
+       debut, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, &
+       temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, &
+       agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice.
+! The routine reads data from climatologie file and does some calculations at the 
+! surface. 
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: debut
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno !? put to 0 in ocean
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER                     :: i
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_lim, zx_sl
+    LOGICAL                     :: check=.FALSE.
+    REAL, DIMENSION(klon,nbsrf) :: pctsrf_lim
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_forced_noice'
+
+!****************************************************************************************
+! 1)    
+! Read from climatologie file SST and fraction of sub-surfaces
+!
+!****************************************************************************************
+! Get from file tsurf_lim and pctsrf_lim
+    CALL interfoce_lim(itime, dtime, jour, & 
+         knon, knindex, &
+         debut, &
+         tsurf_lim, pctsrf_lim)
+    
+!****************************************************************************************
+! 2)
+! Flux calculation
+!
+!****************************************************************************************
+! Set some variables for calcul_fluxs
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+  
+! 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, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!****************************************************************************************
+! 3)
+! Calculate tmp_flux_o
+!
+!****************************************************************************************
+!IM: flux ocean-atmosphere utile pour le "slab" ocean
+! The flux are written to hist file
+    tmp_flux_o(:) = 0.0
+    DO i=1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf_new(i) .LT. RTT) zx_sl(i) = RLSTT
+
+!IM     flux_o(i) = fluxsens(i)-evap(i)*zx_sl(i)
+!       flux_o(i) = fluxsens(i) + fluxlat(i)
+       IF (pctsrf_lim(knindex(i),is_oce) .GT. epsfra) THEN
+          tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+       ENDIF
+    ENDDO
+
+!****************************************************************************************
+! 4)
+! Return the new values for the ocean fraction
+!
+!****************************************************************************************
+
+    pctsrf_oce(:) = pctsrf_lim(:,is_oce)
+
+  END SUBROUTINE ocean_forced_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_ice(itime, dtime, jour, knon, knindex, &
+       debut, &
+       tsurf_in, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine treats the ocean where there is ice. 
+! The routine reads data from climatologie file and does flux calculations at the 
+! surface.
+!    
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    LOGICAL, INTENT(IN)                  :: debut
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_sic
+
+
+! Local variables
+!****************************************************************************************
+    LOGICAL                     :: check=.FALSE.
+    INTEGER                     :: i
+    REAL                        :: zfra
+    REAL, PARAMETER             :: t_grnd=271.35
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_tmp
+    REAL, DIMENSION(klon)       :: soilcap, soilflux
+    REAL, DIMENSION(klon,nbsrf) :: pctsrf_lim
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! 1)    
+! Read from climatologie file SST and fraction of sub-surfaces
+!
+!****************************************************************************************
+    CALL interfoce_lim(itime, dtime, jour, & 
+         knon, knindex, &
+         debut, &
+         tsurf_tmp, pctsrf_lim)
+  
+    DO i = 1, knon
+       tsurf_tmp(i) = tsurf_in(i)
+       IF (pctsrf_lim(knindex(i),is_sic) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_tmp(i) = RTT - 1.8
+          IF (soil_model) tsoil(i,:) = RTT -1.8
+       ENDIF
+    ENDDO
+
+!****************************************************************************************
+! 2) 
+! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, 
+!                    dflux_s, dflux_l and qsurf
+!****************************************************************************************
+
+! calculate the parameters cal, beta, capsol and dif_grnd
+
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+    IF (soil_model) THEN 
+! update tsoil and calculate soilcap and soilflux
+       CALL soil(dtime, is_sic, knon,snow, tsurf_tmp, tsoil,soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+       dif_grnd = 1.0 / tau_gl
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+
+    beta = 1.0
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_tmp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!****************************************************************************************
+! 3)
+! Calculations due to snow and runoff
+!
+!****************************************************************************************
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_tmp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+    
+! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno)
+! 
+    CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:))  
+
+    WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0.
+
+    alb_new(:) = 0.0
+    DO i=1, knon
+       zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0)))
+       alb_new(i) = alb_neig(i) * zfra +  0.6 * (1.0-zfra)
+    ENDDO
+!!      alb_new(1 : knon) = 0.6
+
+!****************************************************************************************
+! 4)
+! Calculate tmp_flux_g
+!
+!****************************************************************************************
+!
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+!IM: faire dependre le coefficient de conduction de la glace de mer
+!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!    actuel correspond a 3m de glace de mer, cf. L.Li
+!
+       IF (cal(i) .GT. 1.0e-15 .AND. pctsrf_lim(knindex(i),is_sic) .GT. epsfra) &
+            tmp_flux_g(knindex(i)) = (tsurf_new(i)-t_grnd) * dif_grnd(i) *RCPD/cal(i)
+       
+    ENDDO
+
+!!$    z0_new = 0.002
+!!$    z0_new = SQRT(z0_new**2+rugoro**2)
+    alblw(1:knon) = alb_new(1:knon)
+
+!****************************************************************************************
+! 5)
+! Return the new values for the seaice fraction
+!
+!****************************************************************************************
+
+    pctsrf_sic(:) = pctsrf_lim(:,is_sic)
+
+  END SUBROUTINE ocean_forced_ice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_get_vars(flux_o, flux_g)
+! Get some variables from module oceanforced.
+! This subroutine returns variables to a external routine
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g
+
+! Initialize the output variables
+    flux_o(:) = tmp_flux_o(:)
+    flux_g(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_forced_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_forced_mod
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ocean_slab_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ocean_slab_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ocean_slab_mod.F90	(revision 984)
@@ -0,0 +1,648 @@
+!
+! $Header$
+!
+MODULE ocean_slab_mod
+!
+! This module is used for both surface ocean and sea-ice when using the slab ocean,
+! "ocean=slab".
+!
+  USE surface_data,     ONLY : tau_gl, calice, calsno
+  USE fonte_neige_mod,  ONLY : fonte_neige
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+  USE dimphy
+  
+  IMPLICIT NONE
+
+  INTEGER, PRIVATE, SAVE                           :: lmt_pas, julien, idayvrai
+  !$OMP THREADPRIVATE(lmt_pas,julien,idayvrai)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_seaice
+  !$OMP THREADPRIVATE(tmp_seaice)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_tslab_loc
+  !$OMP THREADPRIVATE(tmp_tslab_loc)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slab_bils
+  !$OMP THREADPRIVATE(slab_bils)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE , SAVE  :: lmt_bils
+  !$OMP THREADPRIVATE(lmt_bils)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tmp_pctsrf_slab
+  !$OMP THREADPRIVATE(tmp_pctsrf_slab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_tslab
+  !$OMP THREADPRIVATE(tmp_tslab)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_radsol
+  !$OMP THREADPRIVATE(tmp_radsol)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: tmp_flux_o, tmp_flux_g
+  !$OMP THREADPRIVATE(tmp_flux_o,tmp_flux_g)
+  LOGICAL, PRIVATE, SAVE                           :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_init(dtime, tslab_rst, seaice_rst, pctsrf_rst)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+
+! Input variables
+!****************************************************************************************
+    REAL, INTENT(IN)                         :: dtime
+! Variables read from restart file
+    REAL, DIMENSION(klon), INTENT(IN)        :: tslab_rst          
+    REAL, DIMENSION(klon), INTENT(IN)        :: seaice_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf_rst
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: error
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'ocean_slab_intit'
+
+
+    WRITE(lunout,*) '************************'
+    WRITE(lunout,*) 'SLAB OCEAN est actif, prenez precautions !'
+    WRITE(lunout,*) '************************'    
+
+! Allocate variables initialize from restart fields
+    ALLOCATE(tmp_tslab(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_tslab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_tslab(:) = tslab_rst(:)
+
+    ALLOCATE(tmp_tslab_loc(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_tslab_loc'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_tslab_loc(:) = tslab_rst(:)
+
+    ALLOCATE(tmp_seaice(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_seaice'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_seaice(:) = seaice_rst(:)
+
+    ALLOCATE(tmp_pctsrf_slab(klon,nbsrf), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_pctsrf_slab'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    tmp_pctsrf_slab(:,:) = pctsrf_rst(:,:)
+    
+! Allocate some other variables internal in module mod_oceanslab
+    ALLOCATE(tmp_radsol(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_radsol'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    ALLOCATE(tmp_flux_o(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_o'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+    ALLOCATE(tmp_flux_g(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_flux_g'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+! a mettre un slab_bils aussi en force !!!
+    ALLOCATE(slab_bils(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slab_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    slab_bils(:) = 0.0   
+
+    ALLOCATE(lmt_bils(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation lmt_bils'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+
+! pour une lecture une fois par jour    
+    lmt_pas = NINT(86400./dtime * 1.0) 
+
+  END SUBROUTINE ocean_slab_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_noice( & 
+       dtime, knon, knindex, &
+       p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, agesno, &
+       evap, fluxsens, fluxlat, &
+       tsurf_new, &
+       dflux_s, dflux_l, pctsrf_oce)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+    
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)   :: pctsrf_oce
+
+! Local variables
+!****************************************************************************************
+    INTEGER                :: i
+    REAL, DIMENSION(klon)  :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)  :: alb_neig, tsurf_temp
+
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_slab_noice'    
+
+    tsurf_new(1:knon) = tmp_tslab(knindex(1:knon))
+    pctsrf_oce(:)   = tmp_pctsrf_slab(:,is_oce)
+    
+    tsurf_temp(:) = tsurf_new(:)
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+    
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    tmp_flux_o(:) = 0.0
+    tmp_radsol(:) = 0.0
+
+    DO i=1, knon
+       tmp_radsol(knindex(i))=radsol(i)
+       
+       IF (pctsrf_oce(knindex(i)) .GT. epsfra) &
+            tmp_flux_o(knindex(i)) = fluxsens(i) + fluxlat(i)
+    ENDDO
+    
+  END SUBROUTINE ocean_slab_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_ice(   &
+       itime, dtime, jour, knon, knindex, &
+       debut, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, &
+       alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1_lay, v1_lay
+    LOGICAL, INTENT(IN)                  :: debut
+
+!In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_sic
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)                :: alb_neig, tsurf_temp
+    REAL, DIMENSION(klon)                :: soilcap, soilflux
+    REAL, DIMENSION(klon)                :: zfra
+    REAL, PARAMETER                      :: t_grnd=271.35
+    REAL                                 :: amn, amx 
+    REAL, DIMENSION(klon)                :: tslab
+    REAL, DIMENSION(klon)                :: seaice ! glace de mer (kg/m2)
+    REAL, DIMENSION(klon,nbsrf)          :: pctsrf_new
+
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+! Initialization of output variables
+    alb_new(:) = 0.0
+
+!****************************************************************************************
+! 
+!
+!****************************************************************************************
+    IF ( ok_slab_sicOBS) THEN   
+       ! glace de mer observee, lecture conditions limites
+       CALL interfoce_lim(itime, dtime, jour, & 
+            knon, knindex, &
+            debut, &
+            tsurf_new, pctsrf_new)
+
+       tmp_pctsrf_slab(:,:) = pctsrf_new(:,:)
+       WRITE(lunout,*) 'jour lecture pctsrf_new sic =',jour
+
+    ELSE
+       pctsrf_new=tmp_pctsrf_slab
+    ENDIF
+
+    DO i = 1, knon
+       tsurf_new(i) = tsurf(i)
+       IF (pctsrf_new(knindex(i),is_sic) < EPSFRA) THEN
+          snow(i) = 0.0
+          tsurf_new(i) = RTT - 1.8
+          IF (soil_model) tsoil(i,:) = RTT -1.8
+       ENDIF
+    ENDDO
+    
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+    
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_sic, knon, snow, tsurf_new, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+    tsurf_temp = tsurf_new
+    beta = 1.0
+
+!****************************************************************************************
+!
+!
+!****************************************************************************************
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_temp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+!****************************************************************************************
+!     calcul albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & 
+         0.6 * (1.0-zfra(1:knon))
+    !!      alb_new(1 : knon) = 0.6
+
+!
+!IM: flux entre l'ocean et la glace de mer pour le "slab" ocean
+    tmp_flux_g(:) = 0.0
+    DO i = 1, knon
+!
+!IM: faire dependre le coefficient de conduction de la glace de mer
+!    de l'epaisseur de la glace de mer, dans l'hypothese ou le coeff.
+!    actuel correspond a 3m de glace de mer, cf. L.Li
+!
+       IF ((cal(i).GT.1.0e-15) .AND. (pctsrf_new(knindex(i),is_sic) .GT. epsfra)) THEN
+          tmp_flux_g(knindex(i))=(tsurf_new(i)-t_grnd) &
+               * dif_grnd(i) *RCPD/cal(i)
+       ENDIF
+!
+!IM: Attention: ne pas initialiser le tmp_radsol puisque c'est deja fait sur is_oce;
+!IM:            tmp_radsol doit etre le flux solaire qui arrive sur l'ocean 
+!IM:            et non pas celui qui arrive sur la glace de mer
+    ENDDO
+    
+!
+! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean
+!
+
+    IF (check) THEN
+       amn=MIN(tmp_tslab(1),1000.)
+       amx=MAX(tmp_tslab(1),-1000.)
+       DO i=2, klon
+          amn=MIN(tmp_tslab(i),amn)
+          amx=MAX(tmp_tslab(i),amx)
+       ENDDO
+       
+       WRITE(lunout,*) ' debut avant interfoce_slab min max tmp_tslab',amn,amx
+    ENDIF !(check) THEN
+
+    tslab = tmp_tslab   
+
+    CALL interfoce_slab(klon, debut, itime, dtime, jour, &
+         tmp_radsol, tmp_flux_o, tmp_flux_g, tmp_pctsrf_slab, &
+         tslab, seaice, pctsrf_new)
+    
+    tmp_pctsrf_slab=pctsrf_new
+
+    DO i=1, knon
+       tmp_tslab(knindex(i))=tslab(knindex(i))
+    ENDDO
+     
+!!$    z0_new = 0.002
+!!$    z0_new = SQRT(z0_new**2+rugoro**2)
+    alblw(1:knon) = alb_new(1:knon)
+        
+!****************************************************************************************
+! Return the fraction of sea-ice
+! NB! jg : Peut-etre un probleme, faut-il prend aussi tmp_pctsrf_slab(:,is_oce)???
+!****************************************************************************************
+    pctsrf_sic(:) =  tmp_pctsrf_slab(:,is_sic)
+
+
+  END SUBROUTINE ocean_slab_ice
+! 
+!****************************************************************************************
+!
+  SUBROUTINE interfoce_slab(klon, debut, itap, dtime, ijour, &
+       radsol, fluxo, fluxg, pctsrf, &
+       tslab, seaice, pctsrf_slab)
+!
+! Cette routine calcule la temperature d'un slab ocean, la glace de mer 
+! et les pourcentages de la maille couverte par l'ocean libre et/ou 
+! la glace de mer pour un "slab" ocean de 50m
+!
+! Conception: Laurent Li
+! Re-ecriture + adaptation LMDZ4: I. Musat
+!
+! input:
+!   klon         nombre total de points de grille
+!   debut        logical: 1er appel a la physique
+!   itap         numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   ijour        jour dans l'annee en cours
+!   radsol       rayonnement net au sol (LW + SW)
+!   fluxo        flux turbulent (sensible + latent) sur les mailles oceaniques 
+!   fluxg        flux de conduction entre la surface de la glace de mer et l'ocean
+!   pctsrf       tableau des pourcentages de surface de chaque maille
+! output: 
+!   tslab        temperature de l'ocean libre
+!   seaice       glace de mer (kg/m2)
+!   pctsrf_slab  "pourcentages" (valeurs entre 0. et 1.) surfaces issus du slab
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: klon
+    LOGICAL, INTENT(IN)                       :: debut    ! not used
+    INTEGER, INTENT(IN)                       :: itap
+    REAL, INTENT(IN)                          :: dtime       ! not used
+    INTEGER, INTENT(IN)                       :: ijour
+    REAL, DIMENSION(klon), INTENT(IN)         :: radsol
+    REAL, DIMENSION(klon), INTENT(IN)         :: fluxo
+    REAL, DIMENSION(klon), INTENT(IN)         :: fluxg
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)  :: pctsrf
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tslab
+    REAL, DIMENSION(klon), INTENT(OUT)        :: seaice ! glace de mer (kg/m2)
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: pctsrf_slab
+
+! Local variables
+!****************************************************************************************
+    REAL                    :: amn, amx
+    REAL, PARAMETER         :: unjour=86400.
+    REAL, PARAMETER         :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K)
+    REAL, PARAMETER         :: cbing=0.334e+05        ! J/kg
+    REAL, DIMENSION(klon)   :: siceh !hauteur de la glace de mer (m)
+    INTEGER                 :: i
+    REAL                    :: zz, za, zb
+!
+!****************************************************************************************
+!
+    julien = MOD(ijour,360)
+
+    IF (check ) THEN
+       amn=MIN(tmp_tslab_loc(1),1000.)
+       amx=MAX(tmp_tslab_loc(1),-1000.)
+       DO i=2, klon
+          amn=MIN(tmp_tslab_loc(i),amn)
+          amx=MAX(tmp_tslab_loc(i),amx)
+       ENDDO
+
+       WRITE(lunout,*) ' debut min max tslab',amn,amx 
+       WRITE(lunout,*) ' itap,lmt_pas unjour',itap,lmt_pas,unjour
+    ENDIF
+
+    pctsrf_slab(1:klon,1:nbsrf) = pctsrf(1:klon,1:nbsrf)
+!
+! lecture du bilan au sol lmt_bils issu d'une simulation forcee en debut de journee
+! 
+    IF (MOD(itap,lmt_pas) .EQ. 1) THEN 
+       ! 1er pas de temps de la journee
+       idayvrai = ijour
+       CALL condsurf(julien,idayvrai, lmt_bils)
+    ENDIF
+
+    DO i = 1, klon
+       IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+            (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+!
+! fabriquer de la glace si congelation atteinte:
+!          
+          IF (tmp_tslab_loc(i).LT.(RTT-1.8)) THEN
+             zz =  (RTT-1.8)-tmp_tslab_loc(i)
+             tmp_seaice(i) = tmp_seaice(i) + cyang/cbing * zz
+             seaice(i) = tmp_seaice(i)
+             tmp_tslab_loc(i) = RTT-1.8
+          ENDIF
+!
+! faire fondre de la glace si temperature est superieure a 0:
+!
+          IF ((tmp_tslab_loc(i).GT.RTT) .AND. (tmp_seaice(i).GT.0.0)) THEN
+             zz = cyang/cbing * (tmp_tslab_loc(i)-RTT)
+             zz = MIN(zz,tmp_seaice(i))
+             tmp_seaice(i) = tmp_seaice(i) - zz
+             seaice(i) = tmp_seaice(i)
+             tmp_tslab_loc(i) = tmp_tslab_loc(i) - zz*cbing/cyang
+          ENDIF
+!
+! limiter la glace de mer a 10 metres (10000 kg/m2)
+!
+          IF(tmp_seaice(i).GT.45.) THEN
+             tmp_seaice(i) = MIN(tmp_seaice(i),10000.0)
+          ELSE
+             tmp_seaice(i) = 0. 
+          ENDIF
+          seaice(i) = tmp_seaice(i)
+          siceh(i)=tmp_seaice(i)/1000. !en metres
+!
+! determiner la nature du sol (glace de mer ou ocean libre):
+!
+! on fait dependre la fraction de seaice "pctsrf(i,is_sic)" 
+! de l'epaisseur de seaice :
+! pctsrf(i,is_sic)=1. si l'epaisseur de la glace de mer est >= a 20cm
+! et pctsrf(i,is_sic) croit lineairement avec seaice de 0. a 20cm d'epaisseur
+!
+
+          IF(.NOT.ok_slab_sicOBS) THEN
+             pctsrf_slab(i,is_sic)=MIN(siceh(i)/0.20, &
+                  1.-(pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)))
+             pctsrf_slab(i,is_oce)=1.0 - &
+                  (pctsrf_slab(i,is_ter)+pctsrf_slab(i,is_lic)+pctsrf_slab(i,is_sic))
+          ELSE
+             IF (i.EQ.1) WRITE(lunout,*) 'cas ok_slab_sicOBS TRUE : passe sur la modif.'
+          ENDIF !(.NOT.ok_slab_sicOBS) then
+       ENDIF !pctsrf
+    ENDDO
+!
+! Calculer le bilan du flux de chaleur au sol :
+!
+    DO i = 1, klon
+       za = radsol(i) + fluxo(i)
+       zb = fluxg(i)
+       IF((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+            (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+          slab_bils(i)=slab_bils(i)+(za*pctsrf_slab(i,is_oce) &
+               +zb*pctsrf_slab(i,is_sic))/ FLOAT(lmt_pas)
+       ENDIF
+    ENDDO !klon
+!
+! calcul tslab 
+!
+    IF (MOD(itap,lmt_pas).EQ.0) THEN !fin de journee
+!
+! calcul tslab 
+       amn=MIN(tmp_tslab_loc(1),1000.)
+       amx=MAX(tmp_tslab_loc(1),-1000.)
+       DO i = 1, klon
+          IF ((pctsrf_slab(i,is_oce).GT.epsfra).OR. &
+               (pctsrf_slab(i,is_sic).GT.epsfra)) THEN
+             tmp_tslab_loc(i) = tmp_tslab_loc(i) + &
+                  (slab_bils(i)-lmt_bils(i)) &
+                  /cyang*unjour
+
+! on remet l'accumulation a 0
+             slab_bils(i) = 0.
+          ENDIF !pctsrf
+!
+          IF (check) THEN
+             IF(i.EQ.1) THEN  
+                WRITE(lunout,*) 'i tmp_tslab_loc MOD(itap,lmt_pas).EQ.0 sicINTER',i,itap, &
+                     tmp_tslab_loc(i), tmp_seaice(i)
+             ENDIF
+             
+             amn=MIN(tmp_tslab_loc(i),amn)
+             amx=MAX(tmp_tslab_loc(i),amx)
+          ENDIF
+       ENDDO !klon
+    ENDIF !(MOD(itap,lmt_pas).EQ.0) THEN
+
+    IF ( check ) THEN
+       WRITE(lunout,*) 'fin min max tslab',amn,amx 
+    ENDIF
+
+    tslab  = tmp_tslab_loc
+    seaice = tmp_seaice
+
+  END SUBROUTINE interfoce_slab
+!
+!****************************************************************************************  
+!
+  SUBROUTINE ocean_slab_final(tslab_rst, seaice_rst)
+
+! This subroutine will send to phyredem the variables concerning the slab 
+! ocean that should be written to restart file.
+
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: tslab_rst
+    REAL, DIMENSION(klon), INTENT(OUT) :: seaice_rst
+
+!****************************************************************************************
+! Set the output variables
+    tslab_rst(:)  = tmp_tslab(:)
+!    tslab_rst(:)  = tmp_tslab_loc(:)
+    seaice_rst(:) = tmp_seaice(:)
+
+! Deallocation of all variables in module
+    DEALLOCATE(tmp_tslab, tmp_tslab_loc, tmp_pctsrf_slab)
+    DEALLOCATE(tmp_seaice, tmp_radsol, tmp_flux_o, tmp_flux_g)
+    DEALLOCATE(slab_bils, lmt_bils)
+
+  END SUBROUTINE ocean_slab_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_get_vars(tslab_loc, seaice_loc, flux_o_loc, flux_g_loc)
+! "Get some variables from module ocean_slab_mod"
+! This subroutine prints variables to a external routine
+
+    REAL, DIMENSION(klon), INTENT(OUT) :: tslab_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: seaice_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_o_loc
+    REAL, DIMENSION(klon), INTENT(OUT) :: flux_g_loc
+
+! Set the output variables
+    tslab_loc(:)  = tmp_tslab(:)
+    seaice_loc(:) = tmp_seaice(:)
+    flux_o_loc(:) = tmp_flux_o(:)
+    flux_g_loc(:) = tmp_flux_g(:)
+
+  END SUBROUTINE ocean_slab_get_vars
+!
+!****************************************************************************************
+!
+END MODULE ocean_slab_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/orbite.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/orbite.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/orbite.F	(revision 984)
@@ -0,0 +1,325 @@
+!
+! $Header$
+!
+c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+c Objet: pour un jour donne, calculer la longitude vraie de la terre
+c        (par rapport au point vernal-21 mars) dans son orbite solaire
+c        calculer aussi la distance terre-soleil (unite astronomique)
+c======================================================================
+c Arguments:
+c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+c                  vernal (21 mars) en degres
+c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+c======================================================================
+#include "YOMCST.h"
+C
+C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)
+     .     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)
+     .     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)
+     .         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)
+     .         +13.0/12.0*xee*SIN(3.0*ranm)
+c
+      anv=ranv/pir
+      longi=anv+xl
+C
+      dist = (1-R_ecc*R_ecc)
+     .      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END
+c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+c======================================================================
+c Arguments:
+c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+c                   solaire a partir de l'equinoxe de printemps (degre)
+c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+c                   par 24 heures (unite en fraction de 0 a 1)
+c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+c                   la journee (0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+c
+      IF ( lat .GE. (pi_local/2.+lat_sun)
+     .    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)
+     .          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+c
+      frac(i) = omega / pi_local
+c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)
+     .          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,
+     s                  pmu0,frac)
+      USE dimphy
+      IMPLICIT none
+c=============================================================
+c Auteur : O. Boucher (LMD/CNRS)
+c          d'apres les routines zenith et angle de Z.X. Li 
+c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+c          connaissant la declinaison, la latitude et la longitude.
+c Rque   : Different de la routine angle en ce sens que zenang 
+c          fournit des moyennes de pmu0 et non des valeurs 
+c          instantanees, du coup frac prend toutes les valeurs 
+c          entre 0 et 1.
+c Date   : premiere version le 13 decembre 1994
+c          revu pour  GCM  le 30 septembre 1996
+c===============================================================
+c longi----INPUT : la longitude vraie de la terre dans son plan
+c                  solaire a partir de l'equinoxe de printemps (degre)
+c gmtime---INPUT : temps universel en fraction de jour
+c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+c lat------INPUT : latitude en degres
+c long-----INPUT : longitude en degres
+c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+c================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c================================================================
+      real longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+c omega : heure en radian du coucher de soleil 
+c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+c================================================================
+c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+c
+      DO i = 1, klon
+c
+      latr = lat(i) * pi_local / 180.
+c
+c--pose probleme quand lat=+/-90 degres
+c
+c      omega = -TAN(latr)*TAN(lat_sun)
+c      omega = ACOS(omega)
+c      IF (latr.GE.(pi_local/2.+lat_sun)
+c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+c         omega = 0.0       ! nuit polaire
+c      ENDIF
+c      IF (latr.GE.(pi_local/2.-lat_sun)
+c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+c         omega = pi_local  ! journee polaire
+c      ENDIF
+c
+c--remplace par cela (le cas par defaut est different)
+c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)
+     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.
+     .    latr.GT.(-pi_local/2.+lat_sun).AND.
+     .    latr.LT.(pi_local/2.-lat_sun).AND.
+     .    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega
+     .                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) + 
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)        
+      ENDIF
+c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+c
+c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)
+      ENDIF 
+c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +
+     .           COS(latr)*COS(lat_sun)*
+     .           (SIN(omegafin)-SIN(omegadeb))/
+     .           (omegafin-omegadeb)
+c
+      ENDIF
+c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+c
+      ENDIF   !---comparaison omega1 et omega2
+c
+      ENDDO
+c
+      END
+c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,
+     s                   pmu0, fract)
+      USE dimphy
+      IMPLICIT none
+c
+c Auteur(s): Z.X. Li (LMD/ENS)
+c
+c Objet: calculer le cosinus de l'angle zenithal du soleil en
+c        connaissant la declinaison du soleil, la latitude et la
+c        longitude du point sur la terre, et le temps universel
+c
+c Arguments d'entree:
+c     longi  : declinaison du soleil (en degres)
+c     gmtime : temps universel en second qui varie entre 0 et 86400
+c     lat    : latitude en degres
+c     long   : longitude en degres
+c Arguments de sortie:
+c     pmu0   : cosinus de l'angle zenithal
+c
+c====================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+c
+      incl=R_incl * zpir
+c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+c--initialisation a la nuit
+c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+c
+c 1 degre en longitude = 240 secondes en temps
+c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)
+     .           + cos(lat(n)*zpir) * cos(lat_sun)
+     .           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/orografi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/orografi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/orografi.F	(revision 984)
@@ -0,0 +1,1839 @@
+!
+! $Header$
+!
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature             
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG  .                +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG  .                +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE orodrag( nlon,nlev 
+     i                 , kgwd, kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+
+      USE dimphy
+      implicit none
+
+c
+c
+c**** *gwdrag* - does the gravity wave parametrization.
+c
+c     purpose.
+c     --------
+c
+c          this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves
+c
+c**   interface.
+c     ----------
+c          called from *callpar*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c      implicit logical (l)
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+c
+cym      integer nlon, nlev, klevm1
+      integer nlon, nlev
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(klon),
+     *      pvlow(klon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     $       ztauf(klon,klev+1),
+     *       zstab(klon,klev+1),
+     *       zvph(klon,klev+1),
+     *       zrho(klon,klev+1),
+     *       zri(klon,klev+1),
+     *       zpsi(klon,klev+1),
+     *       zzdep(klon,klev)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+cym      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+  200 continue
+c
+c
+c
+      call orosetup
+     *     ( nlon, ktest 
+     *     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress
+     *    ( nlon  , nlev
+     *    , ktest , icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic
+     *    , ztau 
+     *    , pgeom1,zdmod)
+c
+c
+c*         4.      compute stress profile.
+c*                 ------- ------ --------
+c
+  400 continue
+c
+c
+      call gwprofil
+     *       (  nlon , nlev
+     *       , kgwd   , kdx , ktest
+     *       , ikcrith, icrit
+     *       , paphm1, zrho   , zstab ,  zvph
+     *       , zri   , ztau   
+     *       , zdmod , psig  , pstd)
+c
+c
+c*         5.      compute tendencies.
+c*                 -------------------
+c
+  500 continue
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+      ilevp1=klev+1
+c
+c
+      do 524 jk=1,klev
+c
+c
+c     do 523 jl=1,kgwd
+c     ji=kdx(jl)
+c  Modif vectorisation 02/04/2004
+      do 523 ji=kidia,kfdia
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c controle des overshoots:
+c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c fin du controle des overshoots
+c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c simplement oppose au vent
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c  projection dans la direction de l'axe principal de l'orographie
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c     pte(ji,jk)=zdtdt(ji)
+c
+c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+c
+      pte(ji,jk)=0.0
+
+      endif
+  523 continue
+
+  524 continue
+c
+c
+      return
+      end
+      SUBROUTINE orosetup
+     *         ( nlon   , ktest
+     *         , kkcrit, kkcrith, kcrit
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgamma, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+c
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+c
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c
+c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c     print *,' entree gwsetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+c
+      zcons1=1./rd
+cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+c
+
+ 210  continue
+c
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define low-level flow
+c      ---------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define blocked flow
+c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+c
+c*******  setup orography axes and define plane of profiles  *******
+c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+c
+c  ************ define flow in plane of lowlevel stress *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c
+c*         2.2     brunt-vaisala frequency and density at half levels.
+c
+  220 continue
+c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*
+     *                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)
+     *                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+c
+c*         2.3     mean flow richardson number.
+c*                 and critical height for froude layer
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for the breaking
+c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,
+     *          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end
+      SUBROUTINE gwstress
+     *         (  nlon  , nlev
+     *         , ktest, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic  , ptau  
+     *         , pgeom1 , pdmod )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon, nlev
+      integer kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2
+     *    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+     *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+c
+      return
+      end
+      SUBROUTINE GWPROFIL
+     *         ( NLON, NLEV
+     *         , kgwd, kdx , ktest
+     *         , KKCRITH, KCRIT
+     *         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU
+     *         , pdmod   , psig , pvar)
+
+C**** *GWPROFIL*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *GWDRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD:
+C     -------
+C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+C     NONLINEAR GRAVITY WAVE BREAKING.
+C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+C     
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+C-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+C
+
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)
+     *       ,kdx(nlon) , ktest(nlon)
+
+C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),
+     *     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),
+     *     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)
+     
+      REAL pdmod (NLON) , psig(NLON),
+     *     pvar(NLON)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
+      REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
+      REAL ZTAU (KLON,KLEV+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+c      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      ilevh=KLEV/3
+C
+c     DO 400 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      DO 400 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+      endif
+  400 CONTINUE
+  
+C
+      DO 430 JK=KLEV,2,-1
+C
+C
+C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+C                 BLOCKING LAYER.
+  410 CONTINUE
+C
+c     DO 411 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 411 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+C          ENDIF
+C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+      endif
+ 411  CONTINUE             
+C
+C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+C        
+C
+C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+C
+  420 CONTINUE
+C
+c     DO 421 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 421 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)
+     *                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+      endif
+  421 CONTINUE
+C
+C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+C                 LEVEL
+C
+                          
+c     DO 431 ji=1,kgwd
+c     jl=Kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 431 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+      endif
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+c     DO 530 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+      endif
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+c     DO 532 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +
+     .                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*
+     .                ZDELP/ZDELPT
+     
+        ENDIF
+            
+      endif
+ 532  CONTINUE    
+ 
+C  REORGANISATION IN THE STRATOSPHERE
+
+c     DO 533 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+      endif
+ 533  CONTINUE
+
+C REORGANISATION IN THE TROPOSPHERE
+
+c      DO 534 ji=1,kgwd
+c      jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 534 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +
+     *                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP
+     .                                                     /ZDELPT
+
+       ENDIF
+      endif
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,      
+     e                   plat,pmea,pstd, ppic,
+     e                   ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL OROLIFT(klon,klev,ktest,
+     .            dtime,
+     .            papmh, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, ppic,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG .                 +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG .                 +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE OROLIFT( NLON,NLEV
+     I                 , KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PLAT
+     R                 , PMEA, PVAROR, ppic
+C OUTPUTS
+     R                 , PULOW,PVLOW
+     R                 , PVOM,PVOL,PTE )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+      USE dimphy
+      implicit none
+C
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),
+     *      PVOL(NLON,NLEV),
+     *      PVOM(NLON,NLEV),
+     *      PULOW(NLON),
+     *      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),
+     *      PVM1(NLON,NLEV),
+     *      PTM1(NLON,NLEV),
+     *      PLAT(NLON),PMEA(NLON),
+     *      PVAROR(NLON),
+     *      ppic(NLON),
+     *      PGEOM1(NLON,NLEV),
+     *      PAPHM1(NLON,NLEV+1)
+C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      logical lifthigh
+cym      integer klevm1, jl, ilevh, jk
+      integer  jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER  
+     *         IKNUB(klon),
+     *         IKNUL(klon)
+      LOGICAL LL1(KLON,KLEV+1)
+C
+      REAL   ZTAU(KLON,KLEV+1),
+     *       ZTAV(KLON,KLEV+1),
+     *       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),
+     *       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+C-----------------------------------------------------------------------
+C
+C*         1.1  INITIALIZATIONS
+C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)STOP
+      ZCONS1=1./RD
+cym      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+C     do 2011 jl=kidia,kfdia
+C     IF(KTEST(JL).EQ.1) THEN
+C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+C     ENDIF
+C2011 continue
+
+C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 223'
+
+C********************************************************************
+C
+C*     DEFINE LOW LEVEL FLOW
+C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)
+     *               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 CONTINUE
+C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      IF(LIFTHIGH)THEN
+C
+  500 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 500'
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END
+
+
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+c      USE parallel
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PSIG        : VERTICAL COORDINATE TABLE
+C        NLEV        : NUMBER OF MODEL LEVELS
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C        ECMWF Research Department documentation of the IFS
+C
+C     AUTHOR.
+C     -------
+C        MARTIN MILLER             *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01
+C     ------------------------------------------------------------------
+      implicit none
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+      integer nlon,nlev, jk
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+C
+C*       1.    SET THE VALUES OF THE PARAMETERS
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+      
+            
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2,jk)/paprs_glo(klon_glo/2,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+
+
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+C
+      GKLIFT=0.50  
+      GVCRIT =0.0
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=1.E-12
+C
+      GTSEC=1.E-07
+C
+C      ----------------------------------------------------------------
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ozonecm.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ozonecm.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ozonecm.F	(revision 984)
@@ -0,0 +1,89 @@
+!
+! $Header$
+!
+      SUBROUTINE ozonecm(rjour, rlat, paprs, o3)
+      USE dimphy
+      IMPLICIT none
+C
+C The ozone climatology is based on an analytic formula which fits the
+C Krueger and Mintzner (1976) profile, as well as the variations with
+C altitude and latitude of the maximum ozone concentrations and the total
+C column ozone concentration of Keating and Young (1986). The analytic
+C formula have been established by J-F Royer (CRNM, Meteo France), who
+C also provided us the code.
+C
+C A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the
+C 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976).
+C
+C Keating, G. M. and D. F. Young, 1985: Interim reference models for the
+C middle atmosphere, Handbook for MAP, vol. 16, 205-229.
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+#include "YOMCST.h"
+      REAL rlat(klon), paprs(klon,klev+1)
+      REAL o3(klon,klev)   ! ozone concentration in kg/kg
+      REAL tozon, rjour, pi, pl
+      INTEGER i, k
+C----------------------------------------------------------
+      REAL field(klon,klev+1)
+      REAL ps
+      PARAMETER (ps=101325.0)
+      REAL an, unit, zo3q3
+      SAVE an, unit, zo3q3
+c$OMP THREADPRIVATE(an, unit, zo3q3)
+      REAL mu,gms, zslat, zsint, zcost, z, ppm, qpm, a
+      REAL asec, bsec, aprim, zo3a3
+C----------------------------------------------------------
+c         data an /365.25/   (meteo)
+      DATA an /360.00/
+      DATA unit /2.1415e-05/
+      DATA zo3q3 /4.0e-08/
+
+      pi = 4.0 * ATAN(1.0)
+      DO k = 1, klev
+      DO i = 1, klon
+      zslat = SIN(pi/180.*rlat(i))
+      zsint = SIN(2.*pi*(rjour+15.)/an)
+      zcost = COS(2.*pi*(rjour+15.)/an)
+      z = 0.0531+zsint*(-0.001595+0.009443*zslat) +
+     .  zcost*(-0.001344-0.00346*zslat) +
+     .  zslat**2*(.056222+zslat**2*(-.037609
+     . +.012248*zsint+.00521*zcost+.008890*zslat))
+      zo3a3 = zo3q3/ps/2.
+      z = z-zo3q3*ps
+      gms = z
+      mu = ABS(sin(pi/180.*rlat(i)))
+      ppm = 800.-(500.*zslat+150.*zcost)*zslat
+      qpm = 1.74e-5-(7.5e-6*zslat+1.7e-6*zcost)*zslat
+      bsec = 2650.+5000.*zslat**2
+      a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
+      a = a/(bsec**(3./2.)+ppm**(3./2.))**2
+      aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
+      aprim = amax1(0.,aprim)
+      asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
+      asec = AMAX1(0.0,asec)
+      aprim = gms-asec/(1.+(bsec/ps)**(3./2.))
+      pl = paprs(i,k)
+      tozon = aprim/(1.+3.*(ppm/pl)**2)+asec/(1.+(bsec/pl)**(3./2.))
+     .  + zo3a3*pl*pl
+      tozon = tozon / 9.81  ! en kg/m**2
+      tozon = tozon / unit  ! en kg/m**2  > u dobson (10e-5 m)
+      tozon = tozon / 1000. ! en cm
+      field(i,k) = tozon
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         field(i,klev+1) = 0.0
+      ENDDO
+      DO k = 1, klev
+        DO i = 1, klon
+          o3(i,k) = field(i,k) - field(i,k+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/pbl_surface_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/pbl_surface_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/pbl_surface_mod.F90	(revision 984)
@@ -0,0 +1,1260 @@
+!
+! $Header$
+!
+MODULE pbl_surface_mod
+!
+! Planetary Boundary Layer and Surface module
+!
+! This module manage the calculation of turbulent diffusion in the boundary layer 
+! and all interactions towards the differents sub-surfaces.
+!
+!
+  USE dimphy
+  USE mod_phys_lmdz_para,  ONLY : mpi_size
+  USE ioipsl
+  USE surface_data,        ONLY : ocean, ok_veget
+  USE surf_land_mod,       ONLY : surf_land
+  USE surf_landice_mod,    ONLY : surf_landice
+  USE surf_ocean_mod,      ONLY : surf_ocean
+  USE surf_seaice_mod,     ONLY : surf_seaice
+  USE cpl_mod,             ONLY : gath2cpl
+  USE climb_hq_mod,        ONLY : climb_hq_down, climb_hq_up
+  USE climb_wind_mod,      ONLY : climb_wind_down, climb_wind_up
+  USE coef_diff_turb_mod,  ONLY : coef_diff_turb
+
+  IMPLICIT NONE
+
+! Declaration of variables saved in restart file
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: qsol
+  !$OMP THREADPRIVATE(qsol)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: fder
+  !$OMP THREADPRIVATE(fder)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: snow
+  !$OMP THREADPRIVATE(snow)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: qsurf
+  !$OMP THREADPRIVATE(qsurf)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: evap
+  !$OMP THREADPRIVATE(evap)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: rugos
+  !$OMP THREADPRIVATE(rugos)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: agesno
+  !$OMP THREADPRIVATE(agesno)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: ftsoil  
+  !$OMP THREADPRIVATE(ftsoil)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,&
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+! This routine should be called after the restart file has been read.
+! This routine initialize the restart variables and does some validation tests
+! for the index of the different surfaces and tests the choice of type of ocean.
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "iniprint.h"
+ 
+! 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
+
+  
+! Local variables
+!****************************************************************************************
+    INTEGER                       :: ierr
+    CHARACTER(len=80)             :: abort_message
+    CHARACTER(len = 20)           :: modname = 'pbl_surface_init'
+    
+
+!****************************************************************************************
+! Allocate and initialize module variables with fields read from restart file.
+!
+!****************************************************************************************    
+    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)
+
+    ALLOCATE(snow(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(qsurf(klon,nbsrf), stat=ierr)
+    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(:,:,:)
+
+
+!****************************************************************************************
+! Test for sub-surface indices
+!
+!****************************************************************************************
+    IF (is_ter /= 1) THEN 
+      WRITE(lunout,*)" *** Warning ***"
+      WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter
+      WRITE(lunout,*)"or on doit commencer par les surfaces continentales"
+      abort_message="voir ci-dessus"
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_oce > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' l''ocean doit etre traite avant la banquise'
+      WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_lic > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer'
+      WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Validation of ocean mode
+!
+!****************************************************************************************
+
+    IF (ocean /= 'slab  ' .AND. ocean /= 'force ' .AND. ocean /= 'couple') THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)'Option couplage pour l''ocean = ', ocean
+      abort_message='option pour l''ocean non valable'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Test of coherence between variable ok_veget and cpp key CPP_VEGET
+!
+!****************************************************************************************
+    IF (ok_veget) THEN
+#ifndef CPP_VEGET
+       abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.'
+       CALL abort_gcm(modname,abort_message,1)
+#endif
+    ENDIF
+
+
+  END SUBROUTINE pbl_surface_init
+!  
+!****************************************************************************************
+!  
+
+  SUBROUTINE pbl_surface( &
+       dtime,     date0,     itap,     jour,          &
+       debut,     lafin,                              &
+       rlon,      rlat,      rugoro,   rmu0,          &
+       rain_f,    snow_f,    solsw_m,  sollw_m,       &
+       t,         q,         u,        v,             &
+       pplay,     paprs,     pctsrf,                  &
+       ts,        albe,      alblw,    u10m,   v10m,  &
+       sollwdown, cdragh,    cdragm,   zu1,    zv1,   &
+       albsol,    albsollw,  zxsens,   zxevap,        &
+       zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
+       d_t,       d_q,       d_u,      d_v,           & 
+       zcoefh,    pctsrf_new,                         &
+       qsol_d,    zq2m,      s_pblh,   s_plcl,        &
+       s_capCL,   s_oliqCL,  s_cteiCL, s_pblT,        &
+       s_therm,   s_trmb1,   s_trmb2,  s_trmb3,       &
+       zxrugs,    zu10m,     zv10m,    fder_print,    &
+       zxqsurf,   rh2m,      zxfluxu,  zxfluxv,       &
+       rugos_d,   agesno_d,  sollw,    solsw,         &
+       d_ts,      evap_d,    fluxlat,  t2m,           &
+       wfbils,    wfbilo,    flux_t,   flux_u, flux_v,&
+       dflux_t,   dflux_q,   zxsnow,                  &
+       zxfluxt,   zxfluxq,   q2m,      flux_q, tke    )
+!****************************************************************************************
+! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+! Objet: interface de "couche limite" (diffusion verticale)
+!
+!AA REM:
+!AA-----
+!AA Tout ce qui a trait au traceurs est dans phytrac maintenant
+!AA pour l'instant le calcul de la couche limite pour les traceurs
+!AA se fait avec cltrac et ne tient pas compte de la differentiation
+!AA des sous-fraction de sol.
+!AA REM bis :
+!AA----------
+!AA Pour pouvoir extraire les coefficient d'echanges et le vent 
+!AA dans la premiere couche, 3 champs supplementaires ont ete crees
+!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
+!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir 
+!AA si les informations des subsurfaces doivent etre prises en compte
+!AA il faudra sortir ces memes champs en leur ajoutant une dimension, 
+!AA c'est a dire nbsrf (nbre de subsurface).
+!
+! Arguments:
+!
+! dtime----input-R- interval du temps (secondes)
+! itap-----input-I- numero du pas de temps
+! date0----input-R- jour initial
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! ts-------input-R- temperature du sol (en Kelvin)
+! paprs----input-R- pression a intercouche (Pa)
+! pplay----input-R- pression au milieu de couche (Pa)
+! rlat-----input-R- latitude en degree
+! rugos----input-R- longeur de rugosite (en m)
+!
+! d_t------output-R- le changement pour "t"
+! d_q------output-R- le changement pour "q"
+! d_u------output-R- le changement pour "u"
+! d_v------output-R- le changement pour "v"
+! d_ts-----output-R- le changement pour "ts"
+! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)
+!                    (orientation positive vers le bas)
+! tke---input/output-R- tke (kg/m**2/s)
+! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
+! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
+! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
+! dflux_t--output-R- derive du flux sensible
+! dflux_q--output-R- derive du flux latent
+! zu1------output-R- le vent dans la premiere couche
+! zv1------output-R- le vent dans la premiere couche
+! trmb1----output-R- deep_cape
+! trmb2----output-R- inhibition 
+! trmb3----output-R- Point Omega
+! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL
+! plcl-----output-R- Niveau de condensation
+! pblh-----output-R- HCL
+! pblT-----output-R- T au nveau HCL
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+    INCLUDE "dimensions.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "temps.h"
+    INCLUDE "control.h"
+
+! Input variables
+!****************************************************************************************
+    REAL,                         INTENT(IN)        :: dtime
+    REAL,                         INTENT(IN)        :: date0
+    INTEGER,                      INTENT(IN)        :: itap
+    INTEGER,                      INTENT(IN)        :: jour    ! jour de l'annee en cours
+    LOGICAL,                      INTENT(IN)        :: debut, lafin
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rmu0    ! cosinus de l'angle solaire zenithal
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rain_f, snow_f
+    REAL, DIMENSION(klon),        INTENT(IN)        :: solsw_m ! mean value
+    REAL, DIMENSION(klon),        INTENT(IN)        :: sollw_m ! mean value
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: t, q
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: u, v
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: pplay
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)        :: paprs
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)        :: pctsrf
+
+! Input/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: ts
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: albe
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alblw
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: u10m, v10m
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: sollwdown
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: cdragh, cdragm
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu1
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: albsol
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: albsollw
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxsens, zxevap
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxtsol
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxfluxlat
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zt2m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsat2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_t, d_q
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_u, d_v
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zcoefh
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: pctsrf_new
+
+! Output only for diagnostics
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol_d
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zq2m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblh
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_plcl
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_capCL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_oliqCL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_cteiCL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblT
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_therm
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb1
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb2
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb3
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxrugs
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu10m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv10m
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: fder_print
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxqsurf
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: rh2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxu, zxfluxv
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: rugos_d
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: agesno_d
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: sollw, solsw
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: d_ts
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: evap_d
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: fluxlat
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: t2m
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: wfbils, wfbilo
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u, flux_v
+
+! Output not needed
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: dflux_t, dflux_q
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: zxsnow
+    REAL, DIMENSION(klon, klev), INTENT(OUT)        :: zxfluxt, zxfluxq
+    REAL, DIMENSION(klon, nbsrf),INTENT(OUT)        :: q2m
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q
+
+! Input/output
+    REAL, DIMENSION(klon, klev+1, nbsrf), INTENT(INOUT) :: tke
+
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER, SAVE                            :: nhoridbg, nidbg
+!$OMP THREADPRIVATE(nhoridbg, nidbg)
+    LOGICAL, SAVE                            :: debugindex=.FALSE.
+!$OMP THREADPRIVATE(debugindex)
+    LOGICAL, SAVE                            :: first_call=.TRUE.
+!$OMP THREADPRIVATE(first_call)
+    CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf
+!$OMP THREADPRIVATE(cl_surf)
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                            :: i, k, nsrf 
+    INTEGER                            :: knon, j
+    INTEGER                            :: idayref
+    INTEGER , DIMENSION(klon)          :: ni
+    REAL                               :: zx_alf1, zx_alf2 !valeur ambiante par extrapola
+    REAL                               :: amn, amx
+    REAL, DIMENSION(klon)              :: r_co2_ppm     ! taux CO2 atmosphere
+    REAL, DIMENSION(klon)              :: yts, yrugos, ypct, yz0_new
+    REAL, DIMENSION(klon)              :: yalb
+    REAL, DIMENSION(klon)              :: yalblw
+    REAL, DIMENSION(klon)              :: yu1, yv1
+    REAL, DIMENSION(klon)              :: ysnow, yqsurf, yagesno, yqsol
+    REAL, DIMENSION(klon)              :: yrain_f, ysnow_f
+    REAL, DIMENSION(klon)              :: ysollw, ysolsw, ysollwdown
+    REAL, DIMENSION(klon)              :: yfder
+    REAL, DIMENSION(klon)              :: yrads,yrugoro
+    REAL, DIMENSION(klon)              :: yfluxlat
+    REAL, DIMENSION(klon)              :: y_d_ts
+    REAL, DIMENSION(klon)              :: y_flux_t1, y_flux_q1
+    REAL, DIMENSION(klon)              :: y_dflux_t, y_dflux_q
+    REAL, DIMENSION(klon)              :: u1lay, v1lay
+    REAL, DIMENSION(klon)              :: yt2m, yq2m, yu10m
+    REAL, DIMENSION(klon)              :: yustar
+    REAL, DIMENSION(klon)              :: yu10mx
+    REAL, DIMENSION(klon)              :: yu10my
+    REAL, DIMENSION(klon)              :: ywindsp
+    REAL, DIMENSION(klon)              :: yt10m, yq10m
+    REAL, DIMENSION(klon)              :: ypblh
+    REAL, DIMENSION(klon)              :: ylcl
+    REAL, DIMENSION(klon)              :: ycapCL
+    REAL, DIMENSION(klon)              :: yoliqCL
+    REAL, DIMENSION(klon)              :: ycteiCL
+    REAL, DIMENSION(klon)              :: ypblT
+    REAL, DIMENSION(klon)              :: ytherm
+    REAL, DIMENSION(klon)              :: ytrmb1
+    REAL, DIMENSION(klon)              :: ytrmb2
+    REAL, DIMENSION(klon)              :: ytrmb3
+    REAL, DIMENSION(klon)              :: uzon, vmer
+    REAL, DIMENSION(klon)              :: tair1, qair1, tairsol
+    REAL, DIMENSION(klon)              :: psfce, patm
+    REAL, DIMENSION(klon)              :: qairsol, zgeo1
+    REAL, DIMENSION(klon)              :: rugo1
+    REAL, DIMENSION(klon)              :: yfluxsens, swdown
+    REAL, DIMENSION(klon)              :: petAcoef, peqAcoef, petBcoef, peqBcoef
+    REAL, DIMENSION(klon)              :: ypsref, epot_air
+    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb_new
+    REAL, DIMENSION(klon)              :: pctsrf_nsrf
+    REAL, DIMENSION(klon)              :: ztsol
+    REAL, DIMENSION(klon,klev)         :: y_d_t, y_d_q
+    REAL, DIMENSION(klon,klev)         :: y_d_u, y_d_v
+    REAL, DIMENSION(klon,klev)         :: y_flux_t, y_flux_q
+    REAL, DIMENSION(klon,klev)         :: y_flux_u, y_flux_v
+    REAL, DIMENSION(klon,klev)         :: ycoefh, ycoefm
+    REAL, DIMENSION(klon,klev)         :: yu, yv
+    REAL, DIMENSION(klon,klev)         :: yt, yq
+    REAL, DIMENSION(klon,klev)         :: ypplay, ydelp
+    REAL, DIMENSION(klon,klev)         :: delp
+    REAL, DIMENSION(klon,klev+1)       :: ypaprs
+    REAL, DIMENSION(klon,klev+1)       :: ytke
+    REAL, DIMENSION(klon,nsoilmx)      :: ytsoil
+    REAL, DIMENSION(klon,nbsrf)        :: pctsrf_pot
+    CHARACTER(len=80)                  :: abort_message
+    CHARACTER(len=20)                  :: modname = 'pbl_surface'
+    LOGICAL, PARAMETER                 :: zxli=.FALSE. ! utiliser un jeu de fonctions simples
+    LOGICAL, PARAMETER                 :: check=.FALSE.
+
+! For debugging with IOIPSL
+    INTEGER, DIMENSION(iim*(jjm+1))    :: ndexbg
+    REAL                               :: zjulian
+    REAL, DIMENSION(klon)              :: tabindx
+    REAL, DIMENSION(iim,jjm+1)         :: zx_lon, zx_lat
+    REAL, DIMENSION(iim,jjm+1)         :: debugtab
+
+
+    REAL, DIMENSION(klon,nbsrf)        :: pblh
+    REAL, DIMENSION(klon,nbsrf)        :: plcl
+    REAL, DIMENSION(klon,nbsrf)        :: capCL
+    REAL, DIMENSION(klon,nbsrf)        :: oliqCL
+    REAL, DIMENSION(klon,nbsrf)        :: cteiCL
+    REAL, DIMENSION(klon,nbsrf)        :: pblT
+    REAL, DIMENSION(klon,nbsrf)        :: therm
+    REAL, DIMENSION(klon,nbsrf)        :: trmb1
+    REAL, DIMENSION(klon,nbsrf)        :: trmb2
+    REAL, DIMENSION(klon,nbsrf)        :: trmb3
+    REAL, DIMENSION(klon,nbsrf)        :: zx_rh2m, zx_qsat2m
+    REAL, DIMENSION(klon,nbsrf)        :: zx_qs1, zx_t1
+    REAL, DIMENSION(klon,nbsrf)        :: zdelta1, zcor1
+
+
+!jg+ temporary test
+    REAL, DIMENSION(klon,klev)         :: y_flux_u_old, y_flux_v_old
+    REAL, DIMENSION(klon,klev)         :: y_d_u_old, y_d_v_old
+!jg-
+    
+!****************************************************************************************
+! End of declarations
+!****************************************************************************************
+
+
+!****************************************************************************************
+! 1) Initialisation and validation tests 
+!    Only done first time entering this subroutine
+!
+!****************************************************************************************
+
+
+    IF (first_call) THEN
+       first_call=.FALSE.
+      
+       ! Initilize debug IO
+       IF (debugindex .AND. mpi_size==1) THEN 
+          ! initialize IOIPSL output
+          idayref = day_ini
+          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+          DO i = 1, iim
+             zx_lon(i,1) = rlon(i+1)
+             zx_lon(i,jjm+1) = rlon(i+1)
+          ENDDO
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+          CALL histbeg("sous_index", iim,zx_lon(:,1),jjm+1,zx_lat(1,:), &
+               1,iim,1,jjm+1, &
+               itau_phy,zjulian,dtime,nhoridbg,nidbg) 
+          ! no vertical axis
+          cl_surf(1)='ter'
+          cl_surf(2)='lic'
+          cl_surf(3)='oce'
+          cl_surf(4)='sic'
+          DO nsrf=1,nbsrf
+             CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim, &
+                  jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) 
+          END DO
+
+          CALL histend(nidbg)
+          CALL histsync(nidbg)
+
+       END IF
+       
+    ENDIF
+          
+!****************************************************************************************
+! 2) Initialization to zero 
+!    Done for all local variables that will be compressed later
+!    and argument with INTENT(OUT)
+!****************************************************************************************
+    cdragh = 0.0  ; cdragm = 0.0     ; dflux_t = 0.0   ; dflux_q = 0.0
+    ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0     ; zu1 = 0.0        
+    zv1 = 0.0     ; yqsurf = 0.0     ; yalb = 0.0      ; yalblw = 0.0    
+    yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0    
+    ysollw = 0.0  ; ysollwdown = 0.0 ; yrugos = 0.0    ; yu1 = 0.0    
+    yv1 = 0.0     ; yrads = 0.0      ; ypaprs = 0.0    ; ypplay = 0.0
+    ydelp = 0.0   ; yu = 0.0         ; yv = 0.0        ; yt = 0.0         
+    yq = 0.0      ; pctsrf_new = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0 
+    yrugoro = 0.0 ; yu10mx = 0.0     ; yu10my = 0.0    ; ywindsp = 0.0   
+    d_ts = 0.0    ; yfluxlat=0.0     ; flux_t = 0.0    ; flux_q = 0.0     
+    flux_u = 0.0  ; flux_v = 0.0     ; d_t = 0.0       ; d_q = 0.0      
+    d_u = 0.0     ; d_v = 0.0        ; zcoefh = 0.0    ; yqsol = 0.0    
+    ytherm = 0.0  ; ytke=0.
+     
+    ytsoil = 999999. 
+
+!****************************************************************************************
+! 3) - Calculate pressure thickness of each layer
+!    - Calculate the wind at first layer
+!
+!****************************************************************************************
+    DO k = 1, klev
+       DO i = 1, klon
+          delp(i,k) = paprs(i,k)-paprs(i,k+1)
+       ENDDO
+    ENDDO
+    DO i = 1, klon
+       zx_alf1 = 1.0
+       zx_alf2 = 1.0 - zx_alf1
+       u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2
+       v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2
+    ENDDO
+
+
+!****************************************************************************************
+! Test for rugos........ from physiq.. A la fin plutot???
+! Calcul de l'abedo moyen par maille
+!****************************************************************************************
+
+    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)
+       ENDDO
+    ENDDO
+
+! Calcul de l'abedo moyen par maille
+    albsol(:)   = 0.0
+    albsollw(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          albsol(i)   = albsol(i)   + albe(i,nsrf)  * pctsrf(i,nsrf)
+          albsollw(i) = albsollw(i) + alblw(i,nsrf) * pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+
+
+
+! Calcule de ztsol (aussi fait dans physiq.F, pourrait etre un argument)
+    ztsol(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+
+
+! Repartition du longwave par sous-surface linearisee
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf))
+          solsw(i,nsrf) = solsw_m(i)*(1.-albe(i,nsrf))/(1.-albsol(i))
+       ENDDO
+    ENDDO
+
+
+    DO i = 1, klon
+       sollwdown(i) = sollw_m(i) + RSIGMA*ztsol(i)**4
+    ENDDO
+
+!****************************************************************************************
+! 4) Loop over different surfaces
+!
+! All points with a possibility of the current surface are used. This is done
+! to allow the sea-ice to appear or disappear. It is considered here that the 
+! entier domaine of the ocean possibly can contain sea-ice.
+! 
+!****************************************************************************************
+
+    pctsrf_pot = pctsrf
+    pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+    pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+      
+    loop_nbsrf: DO nsrf = 1, nbsrf
+
+! Search for index(ni) and size(knon) of domaine to treat
+       ni(:) = 0
+       knon  = 0
+       DO i = 1, klon
+          IF (pctsrf_pot(i,nsrf).GT.epsfra) THEN
+             knon = knon + 1
+             ni(knon) = i
+          ENDIF
+       ENDDO
+
+       ! write index, with IOIPSL
+       IF (debugindex .AND. mpi_size==1) THEN 
+          tabindx(:)=0.
+          DO i=1,knon
+             tabindx(i)=FLOAT(i)
+          END DO
+          debugtab(:,:) = 0.
+          ndexbg(:) = 0
+          CALL gath2cpl(tabindx,debugtab,knon,ni)
+          CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1), ndexbg)
+       ENDIF
+       
+!****************************************************************************************
+! 5) Compress variables 
+!
+!****************************************************************************************
+
+       DO j = 1, knon
+          i = ni(j)
+          ypct(j) = pctsrf(i,nsrf)
+          yts(j) = ts(i,nsrf)
+          ysnow(j) = snow(i,nsrf)
+          yqsurf(j) = qsurf(i,nsrf)
+          yalb(j) = albe(i,nsrf)
+          yalblw(j) = alblw(i,nsrf)
+          yrain_f(j) = rain_f(i)
+          ysnow_f(j) = snow_f(i)
+          yagesno(j) = agesno(i,nsrf)
+          yfder(j) = fder(i)
+          ysolsw(j) = solsw(i,nsrf)
+          ysollw(j) = sollw(i,nsrf)
+          ysollwdown(j) = sollwdown(i)
+          yrugos(j) = rugos(i,nsrf)
+          yrugoro(j) = rugoro(i)
+          yu1(j) = u1lay(i)
+          yv1(j) = v1lay(i)
+          yrads(j) =  ysolsw(j)+ ysollw(j)
+          ypaprs(j,klev+1) = paprs(i,klev+1)
+          yu10mx(j) = u10m(i,nsrf)
+          yu10my(j) = v10m(i,nsrf)
+          ywindsp(j) = SQRT(yu10mx(j)*yu10mx(j) + yu10my(j)*yu10my(j) )
+       END DO
+
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ypaprs(j,k) = paprs(i,k)
+             ypplay(j,k) = pplay(i,k)
+             ydelp(j,k) = delp(i,k)
+             ytke(j,k)=tke(i,k,nsrf)
+             yu(j,k) = u(i,k)
+             yv(j,k) = v(i,k)
+             yt(j,k) = t(i,k)
+             yq(j,k) = q(i,k)
+          ENDDO
+       ENDDO
+       
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ytsoil(j,k) = ftsoil(i,k,nsrf)
+          END DO
+       END DO
+       
+       ! qsol(water height in soil) only for bucket continental model
+       IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             yqsol(j) = qsol(i)
+          END DO
+       ENDIF
+       
+!****************************************************************************************
+! 6) Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+!    atmosphere and coefficients for turbulent diffusion at surface(Cdrag).
+!
+!****************************************************************************************
+
+       CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
+            ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf,  &
+            ycoefm, ycoefh,ytke)
+       
+!****************************************************************************************
+! 
+! 8) "La descente" - "The downhill"
+!  
+!  climb_hq_down and climb_wind_down calculate the coefficients
+!  Ccoef_X et Dcoef_X for X=[H, Q, U, V].
+!  Only the coefficients at surface for H and Q are returned.
+!
+!****************************************************************************************
+
+! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q 
+       CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, &
+            ydelp, yt, yq, dtime, &
+            petAcoef, peqAcoef, petBcoef, peqBcoef)
+
+! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V
+       CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv)
+      
+
+!****************************************************************************************
+! 9) Small calculations
+!
+!****************************************************************************************
+          
+       ypsref(:) = ypaprs(:,1)  
+       epot_air(:) = 0.0
+       epot_air(1:knon) = RCPD*yt(1:knon,1)*(ypsref(1:knon)/ypplay(1:knon,1))**RKAPPA
+
+       swdown(:) = 0.0
+       IF (nsrf .EQ. is_ter) THEN 
+          swdown(1:knon) = ysolsw(1:knon)/(1-yalb(1:knon)) 
+       ELSE 
+          swdown(1:knon) = ysolsw(1:knon)
+       ENDIF
+
+       ! constant CO2
+       r_co2_ppm(:) = co2_ppm
+
+!****************************************************************************************
+!
+! 10) Switch selon current surface
+!     It is necessary to start with the continental surfaces because the ocean
+!     needs their run-off.
+!
+!****************************************************************************************
+       SELECT CASE(nsrf)
+     
+       CASE(is_ter)
+          CALL surf_land(itap, dtime, date0, jour, knon, ni,&
+               rlon, rlat, &
+               debut, lafin, ydelp(:,1), epot_air, r_co2_ppm, ysollwdown, ysolsw, swdown, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, & 
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+     
+       CASE(is_lic)
+          CALL surf_landice(itap, dtime, knon, ni, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+       CASE(is_oce)
+          CALL surf_ocean(rlon, rlat, ysollw, yalb, &
+               yrugos, ywindsp, rmu0, & 
+               yfder, &
+               itap, dtime, jour, knon, ni, &
+               debut, swdown, &
+               ypplay(:,1), ycoefh(:,1), ycoefm(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yagesno, &
+               yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+       CASE(is_sic)
+          CALL surf_seaice( &
+               rlon, rlat, ysollw, yalb, &
+               yfder, &
+               itap, dtime, jour, knon, ni, &
+               debut, lafin, swdown, &
+               yts, ypplay(:,1), ycoefh(:,1), yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               petAcoef, peqAcoef, petBcoef, peqBcoef, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               yrads, ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalblw, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, yalb_new, y_dflux_t, y_dflux_q, pctsrf_nsrf)
+          
+
+       CASE DEFAULT
+          WRITE(lunout,*) 'Surface index = ', nsrf
+          abort_message = 'Surface index not valid'
+          CALL abort_gcm(modname,abort_message,1)
+       END SELECT
+
+!****************************************************************************************
+! Save the fraction of this sub-surface 
+!
+!****************************************************************************************
+       pctsrf_new(:,nsrf) = pctsrf_nsrf(:)
+
+!****************************************************************************************
+! 11) - Calcul the increment of surface temperature
+!     - Update albedo
+!
+!****************************************************************************************
+       y_d_ts(1:knon)   = ytsurf_new(1:knon) - yts(1:knon)
+ 
+       yalb(1:knon) = yalb_new(1:knon)
+
+!****************************************************************************************
+!
+! 12) "La remontee" - "The uphill"
+!
+!  The fluxes (y_flux_X) and tendancy (y_d_X) are calculated 
+!  for X=H, Q, U and V, for all vertical levels.
+!
+!****************************************************************************************
+! H and Q
+       y_flux_t1(:) =  yfluxsens(:)
+       y_flux_q1(:) = -yevap(:)
+
+       CALL climb_hq_up(knon, dtime, yt, yq, &
+            y_flux_q1, y_flux_t1, ypaprs, ypplay, &
+            y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:))    
+       
+! U and V
+       CALL climb_wind_up(knon, dtime, yu, yv, &
+            y_flux_u, y_flux_v, y_d_u, y_d_v)
+
+       DO j = 1, knon
+          y_dflux_t(j) = y_dflux_t(j) * ypct(j)
+          y_dflux_q(j) = y_dflux_q(j) * ypct(j)
+          yu1(j) = yu1(j) *  ypct(j)
+          yv1(j) = yv1(j) *  ypct(j)
+       ENDDO
+
+!****************************************************************************************
+! 13) Transform variables for output format : 
+!     - Decompress
+!     - Multiply with pourcentage of current surface
+!     - Cumulate in global variable
+!
+!****************************************************************************************
+
+       tke(:,:,nsrf)=0.
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ycoefh(j,k) = ycoefh(j,k) * ypct(j)
+             ycoefm(j,k) = ycoefm(j,k) * ypct(j)
+             y_d_t(j,k) = y_d_t(j,k) * ypct(j)
+             y_d_q(j,k) = y_d_q(j,k) * ypct(j)
+             y_d_u(j,k) = y_d_u(j,k) * ypct(j)
+             y_d_v(j,k) = y_d_v(j,k) * ypct(j)
+
+             flux_t(i,k,nsrf) = y_flux_t(j,k)
+             flux_q(i,k,nsrf) = y_flux_q(j,k)
+             flux_u(i,k,nsrf) = y_flux_u(j,k)
+             flux_v(i,k,nsrf) = y_flux_v(j,k)
+
+             tke(i,k,nsrf)=ytke(j,k)
+
+          ENDDO
+       ENDDO
+       
+       evap(:,nsrf) = - flux_q(:,1,nsrf)
+       
+       albe(:, nsrf) = 0.
+       alblw(:, nsrf) = 0.
+       snow(:, nsrf) = 0.
+       qsurf(:, nsrf) = 0.
+       rugos(:, nsrf) = 0.
+       fluxlat(:,nsrf) = 0.
+       DO j = 1, knon
+          i = ni(j)
+          d_ts(i,nsrf) = y_d_ts(j)
+          albe(i,nsrf) = yalb(j)  
+          alblw(i,nsrf) = yalblw(j)
+          snow(i,nsrf) = ysnow(j)  
+          qsurf(i,nsrf) = yqsurf(j)
+          rugos(i,nsrf) = yz0_new(j)
+          fluxlat(i,nsrf) = yfluxlat(j)
+          agesno(i,nsrf) = yagesno(j)  
+          cdragh(i) = cdragh(i) + ycoefh(j,1)
+          cdragm(i) = cdragm(i) + ycoefm(j,1)
+          dflux_t(i) = dflux_t(i) + y_dflux_t(j)
+          dflux_q(i) = dflux_q(i) + y_dflux_q(j)
+          zu1(i) = zu1(i) + yu1(j)
+          zv1(i) = zv1(i) + yv1(j)
+       END DO
+
+       IF ( nsrf .EQ. is_ter ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             qsol(i) = yqsol(j)
+          END DO
+       END IF
+       
+       ftsoil(:,:,nsrf) = 0.
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ftsoil(i, k, nsrf) = ytsoil(j,k)
+          END DO
+       END DO
+       
+       
+#ifdef CRAY
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+#else
+       DO j = 1, knon
+          i = ni(j)
+          DO k = 1, klev
+#endif
+             d_t(i,k) = d_t(i,k) + y_d_t(j,k)
+             d_q(i,k) = d_q(i,k) + y_d_q(j,k)
+             d_u(i,k) = d_u(i,k) + y_d_u(j,k)
+             d_v(i,k) = d_v(i,k) + y_d_v(j,k)
+             zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)
+#ifdef CRAY
+          END DO
+       END DO
+#else
+          END DO
+       END DO
+#endif
+
+!****************************************************************************************
+! 14) Calculate the temperature et relative humidity at 2m and the wind at 10m 
+!     Call HBTM
+!
+!****************************************************************************************
+       t2m(:,nsrf)    = 0.
+       q2m(:,nsrf)    = 0.
+       u10m(:,nsrf)   = 0.
+       v10m(:,nsrf)   = 0.
+
+       pblh(:,nsrf)   = 0.        ! Hauteur de couche limite
+       plcl(:,nsrf)   = 0.        ! Niveau de condensation de la CLA
+       capCL(:,nsrf)  = 0.        ! CAPE de couche limite
+       oliqCL(:,nsrf) = 0.        ! eau_liqu integree de couche limite
+       cteiCL(:,nsrf) = 0.        ! cloud top instab. crit. couche limite
+       pblt(:,nsrf)   = 0.        ! T a la Hauteur de couche limite
+       therm(:,nsrf)  = 0.
+       trmb1(:,nsrf)  = 0.        ! deep_cape
+       trmb2(:,nsrf)  = 0.        ! inhibition 
+       trmb3(:,nsrf)  = 0.        ! Point Omega
+
+#undef T2m     
+#define T2m     
+#ifdef T2m
+! diagnostic t,q a 2m et u, v a 10m
+
+       DO j=1, knon
+          i = ni(j)
+          uzon(j) = yu(j,1) + y_d_u(j,1)
+          vmer(j) = yv(j,1) + y_d_v(j,1)
+          tair1(j) = yt(j,1) + y_d_t(j,1)
+          qair1(j) = yq(j,1) + y_d_q(j,1)
+          zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
+               * (ypaprs(j,1)-ypplay(j,1))
+          tairsol(j) = yts(j) + y_d_ts(j)
+          rugo1(j) = yrugos(j)
+          IF(nsrf.EQ.is_oce) THEN
+             rugo1(j) = rugos(i,nsrf)
+          ENDIF
+          psfce(j)=ypaprs(j,1)
+          patm(j)=ypplay(j,1)
+          qairsol(j) = yqsurf(j)
+       END DO
+       
+
+! Calculate the temperature et relative humidity at 2m and the wind at 10m 
+       CALL stdlevvar(klon, knon, nsrf, zxli, &
+            uzon, vmer, tair1, qair1, zgeo1, &
+            tairsol, qairsol, rugo1, psfce, patm, &
+            yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
+
+       DO j=1, knon
+          i = ni(j)
+          t2m(i,nsrf)=yt2m(j)
+          
+          q2m(i,nsrf)=yq2m(j)
+
+! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
+          u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2)
+          v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2)
+
+       END DO
+
+
+       CALL HBTM(knon, ypaprs, ypplay, &
+            yt2m,yt10m,yq2m,yq10m,yustar, &
+            y_flux_t,y_flux_q,yu,yv,yt,yq, &
+            ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, &
+            ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl)
+       
+       DO j=1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = ypblh(j)
+          plcl(i,nsrf)   = ylcl(j)
+          capCL(i,nsrf)  = ycapCL(j)
+          oliqCL(i,nsrf) = yoliqCL(j)
+          cteiCL(i,nsrf) = ycteiCL(j)
+          pblT(i,nsrf)   = ypblT(j)
+          therm(i,nsrf)  = ytherm(j)
+          trmb1(i,nsrf)  = ytrmb1(j)
+          trmb2(i,nsrf)  = ytrmb2(j)
+          trmb3(i,nsrf)  = ytrmb3(j)
+       END DO
+       
+#else 
+! not defined T2m
+! No calculation
+! Set output variables to zero
+       DO j = 1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = 0.
+          plcl(i,nsrf)   = 0.
+          capCL(i,nsrf)  = 0.
+          oliqCL(i,nsrf) = 0.
+          cteiCL(i,nsrf) = 0.
+          pblT(i,nsrf)   = 0.
+          therm(i,nsrf)  = 0.
+          trmb1(i,nsrf)  = 0.
+          trmb2(i,nsrf)  = 0.
+          trmb3(i,nsrf)  = 0.
+       END DO
+       DO j = 1, knon
+          i = ni(j) 
+          t2m(i,nsrf)=0.
+          q2m(i,nsrf)=0.
+          u10m(i,nsrf)=0.
+          v10m(i,nsrf)=0.
+       END DO
+#endif
+
+!****************************************************************************************
+! 15) End of loop over different surfaces
+!
+!****************************************************************************************
+    END DO loop_nbsrf
+
+!****************************************************************************************
+! 16) Calculate the mean value over all sub-surfaces for som variables
+!
+!     NB!!! jg : Pour garder la convergence numerique j'utilise pctsrf_new comme c'etait 
+!     fait dans physiq.F mais ca devrait plutot etre pctsrf???!!!!! A verifier!
+!****************************************************************************************
+    
+    zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
+    zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO k = 1, klev
+          DO i = 1, klon
+             zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf_new(i,nsrf)
+             zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf_new(i,nsrf)
+          END DO
+       END DO
+    END DO
+
+    DO i = 1, klon
+       zxsens(i)     = - zxfluxt(i,1) ! flux de chaleur sensible au sol
+       zxevap(i)     = - zxfluxq(i,1) ! flux d'evaporation au sol
+       fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i)
+    ENDDO
+   
+
+    DO i = 1, klon
+       IF ( ABS( pctsrf_new(i, is_ter) + pctsrf_new(i, is_lic) + &
+            pctsrf_new(i, is_oce) + pctsrf_new(i, is_sic)  - 1.) .GT. EPSFRA) & 
+            THEN 
+          WRITE(*,*) 'physiq : pb sous surface au point ', i, &
+               pctsrf_new(i, 1 : nbsrf)
+       ENDIF
+    ENDDO
+
+!
+! Incrementer la temperature du sol
+!
+    zxtsol(:) = 0.0  ; zxfluxlat(:) = 0.0
+    zt2m(:) = 0.0    ; zq2m(:) = 0.0 
+    zu10m(:) = 0.0   ; zv10m(:) = 0.0
+    s_pblh(:) = 0.0  ; s_plcl(:) = 0.0 
+    s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0
+    s_cteiCL(:) = 0.0; s_pblT(:) = 0.0
+    s_therm(:) = 0.0 ; s_trmb1(:) = 0.0
+    s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0
+    
+    
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon          
+          ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf)
+          
+          wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) &
+               + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf_new(i,nsrf)
+          wfbilo(i,nsrf) = (evap(i,nsrf) - (rain_f(i) + snow_f(i))) * &
+               pctsrf_new(i,nsrf)
+
+          zxtsol(i)    = zxtsol(i)    + ts(i,nsrf)      * pctsrf_new(i,nsrf)
+          zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf_new(i,nsrf)
+          
+          zt2m(i)  = zt2m(i)  + t2m(i,nsrf)  * pctsrf_new(i,nsrf)
+          zq2m(i)  = zq2m(i)  + q2m(i,nsrf)  * pctsrf_new(i,nsrf)
+          zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf_new(i,nsrf)
+          zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf_new(i,nsrf)
+
+          s_pblh(i)   = s_pblh(i)   + pblh(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_plcl(i)   = s_plcl(i)   + plcl(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_capCL(i)  = s_capCL(i)  + capCL(i,nsrf) * pctsrf_new(i,nsrf)
+          s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf_new(i,nsrf)
+          s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf_new(i,nsrf)
+          s_pblT(i)   = s_pblT(i)   + pblT(i,nsrf)  * pctsrf_new(i,nsrf)
+          s_therm(i)  = s_therm(i)  + therm(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb1(i)  = s_trmb1(i)  + trmb1(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb2(i)  = s_trmb2(i)  + trmb2(i,nsrf) * pctsrf_new(i,nsrf)
+          s_trmb3(i)  = s_trmb3(i)  + trmb3(i,nsrf) * pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+    IF (check) THEN
+       amn=MIN(ts(1,is_ter),1000.)
+       amx=MAX(ts(1,is_ter),-1000.)
+       DO i=2, klon
+          amn=MIN(ts(i,is_ter),amn)
+          amx=MAX(ts(i,is_ter),amx)
+       ENDDO
+       PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx
+    ENDIF
+!
+! If a sub-surface does not exsist for a grid point, the mean value for all 
+! sub-surfaces is distributed.
+!
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN
+             ts(i,nsrf)     = zxtsol(i)
+             t2m(i,nsrf)    = zt2m(i)
+             q2m(i,nsrf)    = zq2m(i)
+             u10m(i,nsrf)   = zu10m(i)
+             v10m(i,nsrf)   = zv10m(i)
+
+! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour
+             pblh(i,nsrf)   = s_pblh(i)
+             plcl(i,nsrf)   = s_plcl(i)
+             capCL(i,nsrf)  = s_capCL(i)
+             oliqCL(i,nsrf) = s_oliqCL(i) 
+             cteiCL(i,nsrf) = s_cteiCL(i)
+             pblT(i,nsrf)   = s_pblT(i)
+             therm(i,nsrf)  = s_therm(i)
+             trmb1(i,nsrf)  = s_trmb1(i)
+             trmb2(i,nsrf)  = s_trmb2(i)
+             trmb3(i,nsrf)  = s_trmb3(i)
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+    DO i = 1, klon
+       fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 
+    ENDDO
+    
+    zxqsurf(:) = 0.0
+    zxsnow(:)  = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf_new(i,nsrf)
+          zxsnow(i)  = zxsnow(i)  + snow(i,nsrf)  * pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+!
+!IM Calculer l'humidite relative a 2m (rh2m) pour diagnostique
+!IM ajout dependance type surface
+    rh2m(:)   = 0.0
+    qsat2m(:) = 0.0
+
+    DO i = 1, klon
+       DO nsrf=1, nbsrf
+          zx_t1(i,nsrf) = t2m(i,nsrf)
+          IF (thermcep) THEN
+             zdelta1(i,nsrf) = MAX(0.,SIGN(1.,rtt-zx_t1(i,nsrf)))
+             zx_qs1(i,nsrf)  = r2es * &
+                  FOEEW(zx_t1(i,nsrf),zdelta1(i,nsrf))/paprs(i,1)
+             zx_qs1(i,nsrf)  = MIN(0.5,zx_qs1(i,nsrf))
+             zcor1(i,nsrf)   = 1./(1.-retv*zx_qs1(i,nsrf))
+             zx_qs1(i,nsrf)  = zx_qs1(i,nsrf)*zcor1(i,nsrf)
+          END IF
+          zx_rh2m(i,nsrf) = q2m(i,nsrf)/zx_qs1(i,nsrf)
+          zx_qsat2m(i,nsrf)=zx_qs1(i,nsrf)
+          rh2m(i) = rh2m(i)+zx_rh2m(i,nsrf)*pctsrf_new(i,nsrf)
+          qsat2m(i)=qsat2m(i)+zx_qsat2m(i,nsrf)*pctsrf_new(i,nsrf)
+       END DO
+    END DO
+
+! 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
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, &
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! 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
+
+ 
+!****************************************************************************************
+! Return module variables for writing to restart file
+!
+!****************************************************************************************    
+    qsol_rst(:)       = qsol(:)
+    fder_rst(:)       = fder(:)
+    snow_rst(:,:)     = snow(:,:)
+    qsurf_rst(:,:)    = qsurf(:,:)
+    evap_rst(:,:)     = evap(:,:)
+    rugos_rst(:,:)    = rugos(:,:)
+    agesno_rst(:,:)   = agesno(:,:)
+    ftsoil_rst(:,:,:) = ftsoil(:,:,:)
+
+!****************************************************************************************
+! Deallocate module variables
+!
+!****************************************************************************************
+    DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
+
+  END SUBROUTINE pbl_surface_final
+!  
+!****************************************************************************************
+!  
+
+END MODULE pbl_surface_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/phyetat0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/phyetat0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/phyetat0.F	(revision 984)
@@ -0,0 +1,1630 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm_etat0,solaire_etat0,
+     .           rlat_p, rlon_p, pctsrf_p, tsol_p,
+     .           ocean_in, ok_veget_in,
+     .           albe_p, alblw_p,
+     .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,
+     .           radsol_p,clesphy0,
+     .           zmea_p,zstd_p,zsig_p,zgam_p,zthe_p,zpic_p,zval_p,
+     .           rugsrel_p,tabcntr0,
+     .           t_ancien_p,q_ancien_p,ancien_ok_p, rnebcon_p, ratqs_p,
+     .           clwcon_p,pbl_tke_p)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE ocean_slab_mod,   ONLY : ocean_slab_init
+      USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+      USE ocean_forced_mod, ONLY : ocean_forced_init
+      USE fonte_neige_mod,  ONLY : fonte_neige_init
+      USE pbl_surface_mod,  ONLY : pbl_surface_init
+      USE surface_data,     ONLY : ocean, ok_veget
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Lecture de l'etat initial pour la physique
+c======================================================================
+#include "dimensions.h"
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
+      INTEGER radpas
+      REAL rlat_p(klon), rlon_p(klon)
+      REAL co2_ppm_etat0
+      REAL solaire_etat0
+      REAL tsol_p(klon,nbsrf)
+      REAL pbl_tke_p(klon,klev,nbsrf)
+      REAL tsoil_p(klon,nsoilmx,nbsrf)
+      REAL tslab_p(klon), seaice_p(klon)
+      REAL qsurf_p(klon,nbsrf)
+      REAL qsol_p(klon)
+      REAL snow_p(klon,nbsrf)
+      REAL albe_p(klon,nbsrf)
+cIM BEG alblw
+      REAL alblw_p(klon,nbsrf)
+cIM END alblw
+      REAL evap_p(klon,nbsrf)
+      REAL radsol_p(klon)
+      REAL rain_fall_p(klon)
+      REAL snow_fall_p(klon)
+      REAL sollw_p(klon)
+      real solsw_p(klon)
+      real fder_p(klon)
+      REAL frugs_p(klon,nbsrf)
+      REAL agesno_p(klon,nbsrf)
+      REAL zmea_p(klon)
+      REAL zstd_p(klon)
+      REAL zsig_p(klon)
+      REAL zgam_p(klon)
+      REAL zthe_p(klon)
+      REAL zpic_p(klon)
+      REAL zval_p(klon)
+      REAL rugsrel_p(klon)
+      REAL pctsrf_p(klon, nbsrf)
+      REAL run_off_lic_0_p(klon)
+      
+      REAL t_ancien_p(klon,klev), q_ancien_p(klon,klev)
+      real rnebcon_p(klon,klev),clwcon_p(klon,klev)
+      real ratqs_p(klon,klev)
+      LOGICAL,SAVE ::  ancien_ok
+      LOGICAL ::  ancien_ok_p
+      
+      REAL zmasq_glo(klon_glo)
+      REAL rlat(klon_glo), rlon(klon_glo)
+      REAL tsol(klon_glo,nbsrf)
+      REAL pbl_tke(klon_glo,klev,nbsrf)
+      REAL tsoil(klon_glo,nsoilmx,nbsrf)
+cIM "slab" ocean
+      REAL tslab(klon_glo), seaice(klon_glo)
+      REAL qsurf(klon_glo,nbsrf)
+      REAL qsol(klon_glo)
+      REAL snow(klon_glo,nbsrf)
+      REAL albe(klon_glo,nbsrf)
+      REAL alblw(klon_glo,nbsrf)
+      REAL evap(klon_glo,nbsrf)
+      REAL radsol(klon_glo)
+      REAL rain_fall(klon_glo)
+      REAL snow_fall(klon_glo)
+      REAL sollw(klon_glo)
+      real solsw(klon_glo)
+      real fder(klon_glo)
+      REAL frugs(klon_glo,nbsrf)
+      REAL agesno(klon_glo,nbsrf)
+      REAL zmea(klon_glo)
+      REAL zstd(klon_glo)
+      REAL zsig(klon_glo)
+      REAL zgam(klon_glo)
+      REAL zthe(klon_glo)
+      REAL zpic(klon_glo)
+      REAL zval(klon_glo)
+      REAL rugsrel(klon_glo)
+      REAL pctsrf(klon_glo, nbsrf)
+      REAL fractint(klon_glo)
+      REAL run_off_lic_0(klon_glo)
+      REAL t_ancien(klon_glo,klev)
+      REAL q_ancien(klon_glo,klev)
+      real rnebcon(klon_glo,klev)
+      real clwcon(klon_glo,klev)
+      real ratqs(klon_glo,klev)
+
+      CHARACTER*6 ocean_in
+      LOGICAL ok_veget_in
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+c
+      REAL xmin, xmax
+c
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil ,k
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length), tabcntr0(length)
+      REAL,SAVE :: tab_cntrl_omp(length)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+      real iolat(jjm+1)
+c
+c Ouvrir le fichier contenant l'etat initial:
+c
+
+c$OMP MASTER
+      print *,'MASTER -x , omp_rank=',omp_rank
+c$OMP END MASTER
+
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+        print*,'fichnom ',fichnom
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Pb d''ouverture du fichier '//fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+      ENDIF
+c$OMP END MASTER
+c
+c Lecture des parametres de controle:
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <controle> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <controle>'
+         CALL abort
+      ENDIF
+      ENDIF
+
+c$OMP END MASTER
+       
+       CALL bcast(tab_cntrl)
+       
+c
+       
+         DO i = 1, length
+           tabcntr0( i ) = tab_cntrl( i )
+         ENDDO
+c
+         cycle_diurne   = .FALSE.
+         soil_model     = .FALSE.
+         new_oliq       = .FALSE.
+         ok_orodr       = .FALSE.
+         ok_orolf       = .FALSE.
+         ok_limitvrai   = .FALSE.
+
+
+         IF( clesphy0(1).NE.tab_cntrl( 5 ) )  THEN
+             tab_cntrl( 5 ) = clesphy0(1)
+         ENDIF
+
+         IF( clesphy0(2).NE.tab_cntrl( 6 ) )  THEN
+             tab_cntrl( 6 ) = clesphy0(2)
+         ENDIF
+
+         IF( clesphy0(3).NE.tab_cntrl( 7 ) )  THEN
+             tab_cntrl( 7 ) = clesphy0(3)
+         ENDIF
+
+         IF( clesphy0(4).NE.tab_cntrl( 8 ) )  THEN
+             tab_cntrl( 8 ) = clesphy0(4)
+         ENDIF
+
+         IF( clesphy0(5).NE.tab_cntrl( 9 ) )  THEN
+             tab_cntrl( 9 ) = clesphy0( 5 )
+         ENDIF
+
+         IF( clesphy0(6).NE.tab_cntrl( 10 ) )  THEN
+             tab_cntrl( 10 ) = clesphy0( 6 )
+         ENDIF
+
+         IF( clesphy0(7).NE.tab_cntrl( 11 ) )  THEN
+             tab_cntrl( 11 ) = clesphy0( 7 )
+         ENDIF
+
+         IF( clesphy0(8).NE.tab_cntrl( 12 ) )  THEN
+             tab_cntrl( 12 ) = clesphy0( 8 )
+         ENDIF
+
+
+         dtime        = tab_cntrl(1)
+         radpas       = tab_cntrl(2)
+         co2_ppm_etat0      = tab_cntrl(3)
+         solaire_etat0      = tab_cntrl(4)
+         iflag_con    = tab_cntrl(5)
+         nbapp_rad    = tab_cntrl(6)
+
+
+         cycle_diurne    = .FALSE.
+         soil_model      = .FALSE.
+         new_oliq        = .FALSE.
+         ok_orodr        = .FALSE.
+         ok_orolf        = .FALSE.
+         ok_limitvrai    = .FALSE.
+
+         IF( tab_cntrl( 7) .EQ. 1. )    cycle_diurne  = .TRUE.
+         IF( tab_cntrl( 8) .EQ. 1. )       soil_model = .TRUE.
+         IF( tab_cntrl( 9) .EQ. 1. )         new_oliq = .TRUE.
+         IF( tab_cntrl(10) .EQ. 1. )         ok_orodr = .TRUE.
+         IF( tab_cntrl(11) .EQ. 1. )         ok_orolf = .TRUE.
+         IF( tab_cntrl(12) .EQ. 1. )     ok_limitvrai = .TRUE.
+
+
+      itau_phy = tab_cntrl(15)
+
+c
+c Lecture des latitudes (coordonnees):
+c
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <latitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlat)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <longitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlon)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+C
+C
+C Lecture du masque terre mer
+C
+
+      ierr = NF_INQ_VARID (nid, "masque", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmasq_glo)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, zmasq_glo)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <masque>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <masque> est absent'
+          PRINT*, 'fichier startphy non compatible avec phyetat0'
+C      CALL abort
+      ENDIF
+
+       
+C Lecture des fractions pour chaque sous-surface
+C
+C initialisation des sous-surfaces
+C
+      pctsrf = 0.
+C
+C fraction de terre
+C
+
+      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid,        
+     .                             pctsrf(1 : klon_glo,is_ter))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo,is_ter))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FTER>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FTER> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C fraction de glace de terre
+C
+      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf(1 : klon_glo,is_lic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo,is_lic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FLIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+c@$$         CALL abort
+      ENDIF
+C
+C fraction d'ocean
+C
+      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf(1 : klon_glo,is_oce))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo,is_oce))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FOCE>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C fraction glace de mer
+C
+      ierr = NF_INQ_VARID (nid, "FSIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, 
+     .                             pctsrf(1 : klon_glo,is_sic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, 
+     .                           pctsrf(1 : klon_glo, is_sic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FSIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+c@$$         CALL abort
+      ENDIF
+
+C
+C  Verification de l'adequation entre le masque et les sous-surfaces
+C
+      fractint( 1 : klon_glo) = pctsrf(1 : klon_glo, is_ter) 
+     $    + pctsrf(1 : klon_glo, is_lic)
+      DO i = 1 , klon_glo
+        IF ( abs(fractint(i) - zmasq_glo(i) ) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0: attention fraction terre pas ', 
+     $          'coherente ', i, zmasq_glo(i), pctsrf(i, is_ter)
+     $          ,pctsrf(i, is_lic)
+        ENDIF 
+      END DO 
+      fractint (1 : klon_glo) =  pctsrf(1 : klon_glo, is_oce) 
+     $    + pctsrf(1 : klon_glo, is_sic)
+      DO i = 1 , klon_glo
+        IF ( abs( fractint(i) - (1. - zmasq_glo(i))) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0 attention fraction ocean pas ', 
+     $          'coherente ', i, zmasq_glo(i) , pctsrf(i, is_oce)
+     $          ,pctsrf(i, is_sic)
+        ENDIF 
+      END DO 
+
+C
+c Lecture des temperatures du sol:
+c
+
+      ierr = NF_INQ_VARID (nid, "TS", nvarid)
+      IF (ierr.NE.NF_NOERR) 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"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "TS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <TS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <TS"//str2//">"
+             CALL abort
+           ENDIF
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              xmin = MIN(tsol(i,nsrf),xmin)
+              xmax = MAX(tsol(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <TS> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(tsol(i,1),xmin)
+            xmax = MAX(tsol(i,1),xmax)
+         ENDDO
+         PRINT*,'Temperature du sol <TS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            tsol(i,nsrf) = tsol(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture des temperatures du sol profond:
+c
+      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
+      ENDIF
+      WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+      ierr = NF_INQ_VARID (nid, 'Tsoil'//str7, nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+         PRINT*, "          Il prend donc la valeur de surface"
+         DO i=1, klon_glo
+             tsoil(i,isoil,nsrf)=tsol(i,nsrf)
+         ENDDO
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil,nsrf))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil,nsrf))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "Lecture echouee pour <Tsoil"//str7//">"
+            CALL abort
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cIM "slab" ocean 
+c
+c Lecture de tslab (pour slab ocean seulement):      
+c
+      IF (ocean_in .eq. 'slab  ') then
+        ierr = NF_INQ_VARID (nid, "TSLAB", nvarid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Le champ <TSLAB> est absent"
+          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tslab)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, tslab)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Lecture echouee pour <TSLAB>"
+          CALL abort
+        ENDIF
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO i = 1, klon_glo
+          xmin = MIN(tslab(i),xmin)
+          xmax = MAX(tslab(i),xmax)
+        ENDDO
+        PRINT*,'Min, Max tslab (utilise si OCEAN=slab )', xmin, xmax
+c
+c Lecture de seaice (pour slab ocean seulement):
+c
+        ierr = NF_INQ_VARID (nid, "SEAICE", nvarid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Le champ <SEAICE> est absent"
+          CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, seaice)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, seaice)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, "phyetat0: Lecture echouee pour <SEAICE>"
+          CALL abort
+        ENDIF
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO i = 1, klon_glo
+          xmin = MIN(seaice(i),xmin)
+          xmax = MAX(seaice(i),xmax)
+        ENDDO
+        PRINT*,'Masse de la glace de mer (utilise si OCEAN=slab)', 
+     $  xmin, xmax
+      ELSE
+        tslab = 0.
+        seaice = 0.
+      ENDIF
+c
+c Lecture de l'humidite de l'air juste au dessus du sol:
+c
+      ierr = NF_INQ_VARID (nid, "QS", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "QS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <QS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <QS"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsurf(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, qsurf(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            qsurf(i,nsrf) = qsurf(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+C
+C Eau dans le sol (pour le modele de sol "bucket")
+C
+      ierr = NF_INQ_VARID (nid, "QSOL", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, qsol)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <QSOL>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <QSOL> est absent'
+          PRINT*, '          Valeur par defaut nulle'
+          qsol(:)=0.
+c@$$         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+        xmin = MIN(qsol(i),xmin)
+        xmax = MAX(qsol(i),xmax)
+      ENDDO
+      PRINT*,'Eau dans le sol (mm) <QSOL>', xmin, xmax
+c
+c Lecture de neige au sol:
+c
+      ierr = NF_INQ_VARID (nid, "SNOW", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "SNOW"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <SNOW"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <SNOW"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <SNOW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            snow(i,nsrf) = snow(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de albedo au sol:
+c
+      ierr = NF_INQ_VARID (nid, "ALBE", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "ALBE"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <ALBE"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <ALBE"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              xmin = MIN(albe(i,nsrf),xmin)
+              xmax = MAX(albe(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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBE>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(albe(i,1),xmin)
+            xmax = MAX(albe(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBE>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            albe(i,nsrf) = albe(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de albedo au sol LW:
+c
+      ierr = NF_INQ_VARID (nid, "ALBLW", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
+c        PRINT*, '          Mais je vais essayer de lire ALBLW**'
+         PRINT*, '          Mais je vais prendre ALBE**'
+         DO nsrf = 1, nbsrf
+           DO i = 1, klon_glo
+             alblw(i,nsrf) = albe(i,nsrf)
+           ENDDO
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBLW> est present'
+         PRINT*, '          J ignore donc les autres ALBLW**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, alblw(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, alblw(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBLW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            xmin = MIN(alblw(i,1),xmin)
+            xmax = MAX(alblw(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBLW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon_glo
+            alblw(i,nsrf) = alblw(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de evaporation:  
+c
+      ierr = NF_INQ_VARID (nid, "EVAP", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "EVAP"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <EVAP"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <EVAP"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <EVAP>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            evap(i,nsrf) = evap(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture precipitation liquide:
+c
+      ierr = NF_INQ_VARID (nid, "rain_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <rain_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rain_fall)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rain_fall)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <rain_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(rain_fall(i),xmin)
+         xmax = MAX(rain_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation liquide rain_f:', xmin, xmax
+c
+c Lecture precipitation solide:
+c
+      ierr = NF_INQ_VARID (nid, "snow_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <snow_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow_fall)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, snow_fall)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <snow_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(snow_fall(i),xmin)
+         xmax = MAX(snow_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation solide snow_f:', xmin, xmax
+c
+c Lecture rayonnement solaire au sol:
+c
+      ierr = NF_INQ_VARID (nid, "solsw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <solsw> est absent'
+         PRINT*, 'mis a zero'
+         solsw = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, solsw)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <solsw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(solsw(i),xmin)
+         xmax = MAX(solsw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
+c
+c Lecture rayonnement IF au sol:
+c
+      ierr = NF_INQ_VARID (nid, "sollw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <sollw> est absent'
+         PRINT*, 'mis a zero'
+         sollw = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, sollw)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <sollw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(sollw(i),xmin)
+         xmax = MAX(sollw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
+      
+      ENDIF  ! is_mpi_root
+c$OMP END MASTER
+
+
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+c
+c Lecture derive des flux:
+c
+      ierr = NF_INQ_VARID (nid, "fder", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <fder> est absent'
+         PRINT*, 'mis a zero'
+         fder = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, fder)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <fder>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(fder(i),xmin)
+         xmax = MAX(fder(i),xmax)
+      ENDDO
+      PRINT*,'Derive des flux fder:', xmin, xmax
+
+c
+c Lecture du rayonnement net au sol:
+c
+      ierr = NF_INQ_VARID (nid, "RADS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RADS> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, radsol)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RADS>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(radsol(i),xmin)
+         xmax = MAX(radsol(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
+c
+c Lecture de la longueur de rugosite 
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUG", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "RUG"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <RUG"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <RUG"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUG>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            frugs(i,nsrf) = frugs(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de l'age de la neige:
+c
+      ierr = NF_INQ_VARID (nid, "AGESNO", nvarid)
+      IF (ierr.NE.NF_NOERR) 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
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "AGESNO"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
+              agesno = 50.0
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <AGESNO"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon_glo
+              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**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <AGESNO>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon_glo
+            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_glo
+            agesno(i,nsrf) = agesno(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "ZMEA", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZMEA> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zmea)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZMEA>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSTD", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSTD> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zstd)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSTD>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSIG", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSIG> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zsig)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSIG>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZGAM", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZGAM> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zgam)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZGAM>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZTHE", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZTHE> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zthe)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZTHE>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZPIC", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZPIC> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zpic)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZPIC>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zpic(i),xmin)
+         xmax = MAX(zpic(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
+c
+      ierr = NF_INQ_VARID (nid, "ZVAL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZVAL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zval)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZVAL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(zval(i),xmin)
+         xmax = MAX(zval(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUGSREL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RUGSREL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugsrel)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rugsrel)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RUGSREL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon_glo
+         xmin = MIN(rugsrel(i),xmin)
+         xmax = MAX(rugsrel(i),xmax)
+      ENDDO
+      PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
+c
+c
+      ancien_ok = .TRUE.
+c
+      ierr = NF_INQ_VARID (nid, "TANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, t_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, t_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      clwcon=0.
+      ierr = NF_INQ_VARID (nid, "CLWCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ CLWCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         clwcon = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, clwcon)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, clwcon)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <CLWCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon)
+      xmax = MAXval(clwcon)
+      PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
+c
+      rnebcon=0.
+      ierr = NF_INQ_VARID (nid, "RNEBCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ RNEBCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         rnebcon = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rnebcon)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, rnebcon)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RNEBCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon)
+      xmax = MAXval(rnebcon)
+      PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
+
+c
+      ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+c Lecture ratqs
+c
+       ratqs=0.
+      ierr = NF_INQ_VARID (nid, "RATQS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RATQS> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ratqs = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ratqs)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, ratqs)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RATQS>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs)
+      xmax = MAXval(ratqs)
+      PRINT*,'(ecart-type) ratqs:', xmin, xmax
+c
+c Lecture run_off_lic_0
+c
+      ierr = NF_INQ_VARID (nid, "RUNOFFLIC0", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         run_off_lic_0 = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, run_off_lic_0)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, run_off_lic_0)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUNOFFLIC0>"
+            CALL abort
+         ENDIF
+      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
+
+
+c Lecture de l'energie cinetique turbulente
+c
+
+      IF (iflag_pbl>1) then
+         PRINT*, 'phyetat0: Le champ <TKE> est absent'
+         PRINT*, '          Mais je vais essayer de lire TKE**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "TKE"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "WARNING phyetat0: <TKE"//str2//"> est absent"
+              pbl_tke(:,:,nsrf)=1.e-8
+           ELSE
+#ifdef NC_DOUBLE
+              ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pbl_tke(1,1,nsrf))
+#else
+              ierr = NF_GET_VAR_REAL(nid, nvarid, pbl_tke(1,1,nsrf))
+#endif
+              IF (ierr.NE.NF_NOERR) THEN
+                PRINT*, "WARNING phyetat0: echec lect <TKE"//str2//">"
+                CALL abort
+              ENDIF
+           ENDIF
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO k = 1, klev
+           DO i = 1, klon_glo
+              xmin = MIN(pbl_tke(i,k,nsrf),xmin)
+              xmax = MAX(pbl_tke(i,k,nsrf),xmax)
+           ENDDO
+           ENDDO
+           PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax
+         ENDDO
+      ENDIF
+
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+      ENDIF ! is_mpi_root
+c
+c$OMP END MASTER
+
+c$OMP MASTER
+cym  en attendant mieux
+        iolat(1)=rlat(1)
+	iolat(jjm+1)=rlat(klon_glo)
+	do i=2,jjm
+	  iolat(i)=rlat(2+(i-2)*iim)
+	enddo
+	CALL bcast_mpi(iolat)
+	CALL bcast_mpi(rlon)
+        call init_iophy(iolat,rlon(2:iim+1))
+       
+c$OMP END MASTER
+      	
+      call Scatter( rlat,rlat_p)
+      call Scatter( rlon,rlon_p)
+      call Scatter( tsol,tsol_p)
+      IF (iflag_pbl>1) then
+         call Scatter( pbl_tke,pbl_tke_p)
+      endif
+      call Scatter( tsoil,tsoil_p)
+      call Scatter( tslab,tslab_p)
+      call Scatter( seaice,seaice_p)
+      call Scatter( qsurf,qsurf_p)
+      call Scatter( qsol,qsol_p)
+      call Scatter( snow,snow_p)
+      call Scatter( albe,albe_p)
+      call Scatter( alblw,alblw_p)
+      call Scatter( evap,evap_p)
+      call Scatter( radsol,radsol_p)
+      call Scatter( rain_fall,rain_fall_p)
+      call Scatter( snow_fall,snow_fall_p)
+      call Scatter( sollw,sollw_p)
+      call Scatter( solsw,solsw_p)
+      call Scatter( fder,fder_p)
+      call Scatter( frugs,frugs_p)
+      call Scatter( agesno,agesno_p)
+      call Scatter( zmea,zmea_p)
+      call Scatter( zstd,zstd_p)
+      call Scatter( zsig,zsig_p)
+      call Scatter( zgam,zgam_p)
+      call Scatter( zthe,zthe_p)
+      call Scatter( zpic,zpic_p)
+      call Scatter( zval,zval_p)
+      call Scatter( rugsrel,rugsrel_p)
+      call Scatter( pctsrf,pctsrf_p)
+      call Scatter( run_off_lic_0,run_off_lic_0_p)
+      call Scatter( t_ancien,t_ancien_p)
+      call Scatter( q_ancien,q_ancien_p)
+      call Scatter( rnebcon,rnebcon_p)
+      call Scatter( clwcon,clwcon_p)
+      call Scatter( ratqs,ratqs_p)
+      call Scatter( zmasq_glo,zmasq)
+
+c
+c Initilalize variables in module surface_data
+c
+      ok_veget = ok_veget_in
+      ocean    = ocean_in
+c
+c Initialize module pbl_surface_mod 
+c
+      CALL pbl_surface_init(qsol_p, fder_p, snow_p, qsurf_p,
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Initialize ocean module according to ocean type
+      IF ( ocean == 'slab' ) THEN
+c        initilalize module ocean_slab_init
+         CALL ocean_slab_init(dtime, tslab_p, seaice_p, pctsrf_p)
+      ELSEIF ( ocean == 'couple' ) THEN
+c        initilalize module ocean_cpl_init
+         CALL ocean_cpl_init(dtime, rlon_p, rlat_p)
+      ELSE
+c        initilalize module ocean_forced_init
+         CALL ocean_forced_init
+      ENDIF
+c
+c Initilialize module fonte_neige_mod      
+c
+      CALL fonte_neige_init(run_off_lic_0_p)
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/phyredem.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/phyredem.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/phyredem.F	(revision 984)
@@ -0,0 +1,943 @@
+!
+! $Header$
+!
+c
+      SUBROUTINE phyredem (fichnom,dtime,radpas,ocean,
+     .           rlat_p,rlon_p, pctsrf_p,tsol_p,
+     .           albedo_p, alblw_p,
+     .           rain_fall_p, snow_fall_p,solsw_p, sollw_p,
+     .           radsol_p,zmea_p,zstd_p,zsig_p,
+     .           zgam_p,zthe_p,zpic_p,zval_p,rugsrel_p,
+     .           t_ancien_p, q_ancien_p, rnebcon_p, ratqs_p, clwcon_p,
+     .           pbl_tke_p)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE ocean_slab_mod,   ONLY : ocean_slab_final
+      USE fonte_neige_mod,  ONLY : fonte_neige_final
+      USE pbl_surface_mod,  ONLY : pbl_surface_final
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ecriture de l'etat de redemarrage pour la physique
+c======================================================================
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
+      INTEGER radpas
+      REAL rlat_p(klon), rlon_p(klon)
+      REAL tsol_p(klon,nbsrf)
+      REAL pbl_tke_p(klon,klev,nbsrf)
+      REAL tsoil_p(klon,nsoilmx,nbsrf)
+      CHARACTER*6 ocean
+cIM "slab" ocean
+      REAL tslab_p(klon), seaice_p(klon)
+      REAL qsurf_p(klon,nbsrf)
+      REAL qsol_p(klon)
+      REAL snow_p(klon,nbsrf)
+      REAL albedo_p(klon,nbsrf)
+cIM BEG
+      REAL alblw_p(klon,nbsrf)
+cIM END
+      REAL evap_p(klon,nbsrf)
+      REAL rain_fall_p(klon)
+      REAL snow_fall_p(klon)
+      real solsw_p(klon)
+      real sollw_p(klon)
+      real fder_p(klon)
+      REAL radsol_p(klon)
+      REAL frugs_p(klon,nbsrf)
+      REAL agesno_p(klon,nbsrf)
+      REAL zmea_p(klon)
+      REAL zstd_p(klon)
+      REAL zsig_p(klon)
+      REAL zgam_p(klon)
+      REAL zthe_p(klon)
+      REAL zpic_p(klon)
+      REAL zval_p(klon)
+      REAL rugsrel_p(klon)
+      REAL pctsrf_p(klon, nbsrf)
+      REAL t_ancien_p(klon,klev), q_ancien_p(klon,klev)
+      real clwcon_p(klon,klev),rnebcon_p(klon,klev),ratqs_p(klon,klev)
+      REAL run_off_lic_0_p(klon)
+      
+      REAL rlat(klon_glo), rlon(klon_glo)
+      REAL tsol(klon_glo,nbsrf)
+      REAL pbl_tke(klon_glo,klev,nbsrf)
+      REAL tsoil(klon_glo,nsoilmx,nbsrf)
+      REAL tslab(klon_glo), seaice(klon_glo)
+      REAL qsurf(klon_glo,nbsrf)
+      REAL qsol(klon_glo)
+      REAL snow(klon_glo,nbsrf)
+      REAL albedo(klon_glo,nbsrf)
+      REAL alblw(klon_glo,nbsrf)
+      REAL evap(klon_glo,nbsrf)
+      REAL rain_fall(klon_glo)
+      REAL snow_fall(klon_glo)
+      real solsw(klon_glo)
+      real sollw(klon_glo)
+      real fder(klon_glo)
+      REAL radsol(klon_glo)
+      REAL frugs(klon_glo,nbsrf)
+      REAL agesno(klon_glo,nbsrf)
+      REAL zmea(klon_glo)
+      REAL zstd(klon_glo)
+      REAL zsig(klon_glo)
+      REAL zgam(klon_glo)
+      REAL zthe(klon_glo)
+      REAL zpic(klon_glo)
+      REAL zval(klon_glo)
+      REAL rugsrel(klon_glo)
+      REAL pctsrf(klon_glo, nbsrf)
+      REAL t_ancien(klon_glo,klev), q_ancien(klon_glo,klev)
+      REAL clwcon(klon_glo,klev)
+      REAL rnebcon(klon_glo,klev) 
+      REAL ratqs(klon_glo,klev)
+      REAL run_off_lic_0(klon_glo)
+      REAL masq(klon_glo)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+c
+      INTEGER isoil, nsrf
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+
+c======================================================================
+c 
+c Get variables which will be written to restart file from module 
+c pbl_surface_mod
+      CALL pbl_surface_final(qsol_p, fder_p, snow_p, qsurf_p, 
+     $     evap_p, frugs_p, agesno_p, tsoil_p)
+
+c Get a variable calculated in module fonte_neige_mod
+      CALL fonte_neige_final(run_off_lic_0_p)
+
+c If slab ocean then get 2 varaibles from module ocean_slab_mod
+      IF ( ocean == 'slab' ) THEN
+         CALL ocean_slab_final(tslab_p, seaice_p)
+      ELSE 
+         tslab_p(:)  = 0.0
+         seaice_p(:) = 0.0
+      ENDIF      
+
+c======================================================================
+
+      call Gather( rlat_p,rlat)
+      call Gather( rlon_p,rlon)
+      call Gather( tsol_p,tsol)
+      call Gather( pbl_tke_p,pbl_tke)
+      call Gather( tsoil_p,tsoil)
+      call Gather( tslab_p,tslab)
+      call Gather( seaice_p,seaice)
+      call Gather( qsurf_p,qsurf)
+      call Gather( qsol_p,qsol)
+      call Gather( snow_p,snow)
+      call Gather( albedo_p,albedo)
+      call Gather( alblw_p,alblw)
+      call Gather( evap_p,evap)
+      call Gather( radsol_p,radsol)
+      call Gather( rain_fall_p,rain_fall)
+      call Gather( snow_fall_p,snow_fall)
+      call Gather( sollw_p,sollw)
+      call Gather( solsw_p,solsw)
+      call Gather( fder_p,fder)
+      call Gather( frugs_p,frugs)
+      call Gather( agesno_p,agesno)
+      call Gather( zmea_p,zmea)
+      call Gather( zstd_p,zstd)
+      call Gather( zsig_p,zsig)
+      call Gather( zgam_p,zgam)
+      call Gather( zthe_p,zthe)
+      call Gather( zpic_p,zpic)
+      call Gather( zval_p,zval)
+      call Gather( rugsrel_p,rugsrel)
+      call Gather( pctsrf_p,pctsrf)
+      call Gather( run_off_lic_0_p,run_off_lic_0)
+      call Gather( t_ancien_p,t_ancien)
+      call Gather( q_ancien_p,q_ancien)
+      call Gather( rnebcon_p,rnebcon)
+      call Gather( clwcon_p,clwcon)
+      call Gather( ratqs_p,ratqs)
+      call Gather( zmasq,masq)
+      
+c$OMP MASTER
+      IF (is_mpi_root) THEN
+      
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//fichnom
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
+     .                       "Fichier redemmarage physique")
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim1)
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, idim2)
+      ierr = NF_DEF_DIM (nid, "horizon_vertical", klon_glo*klev, idim3)
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      tab_cntrl(1) = dtime
+      tab_cntrl(2) = radpas
+      tab_cntrl(3) = co2_ppm
+      tab_cntrl(4) = solaire
+      tab_cntrl(5) = iflag_con
+      tab_cntrl(6) = nbapp_rad
+
+      IF( cycle_diurne ) tab_cntrl( 7 ) = 1.
+      IF(   soil_model ) tab_cntrl( 8 ) = 1.
+      IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+      IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+      IF(     ok_orolf ) tab_cntrl(11 ) = 1.
+
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = annee_ref
+      tab_cntrl(15) = itau_phy
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Longitudes de la grille physique")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31,
+     .                        "Latitudes de la grille physique")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat)
+#endif
+c
+C PB ajout du masque terre/mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "masque", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16,
+     .                        "masque terre mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masq)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masq)
+#endif      
+c BP ajout des fraction de chaque sous-surface
+C
+C 1. fraction de terre 
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "fraction de continent")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo, is_ter))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_ter))
+#endif
+C 
+C 2. Fraction de glace de terre
+C 
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24,
+     .                        "fraction glace de terre")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo,is_lic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_lic))
+#endif
+C
+C 3. fraction ocean
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "fraction ocean")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo, is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_oce))
+#endif
+C
+C 4. Fraction glace de mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                        "fraction glace mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon_glo, is_sic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon_glo, is_sic))
+#endif
+C
+C
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Temperature de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol(1,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+      DO isoil=1, nsoilmx
+        IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+        WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29,
+     .                        "Temperature du sol No."//str7)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de couches"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf))
+#endif
+      ENDDO
+      ENDDO
+c
+cIM "slab" ocean
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TSLAB", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TSLAB", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Ecart de la SST (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tslab)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tslab)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "SEAICE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "SEAICE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Glace de mer kg/m2 (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,seaice)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,seaice)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
+     .                        "Humidite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsurf(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsurf(1,nsrf))
+#endif
+      END DO
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"QSOL",NF_DOUBLE,1,idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"QSOL",NF_FLOAT,1,idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .    "Eau dans le sol (mm)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo(1,nsrf))
+#endif
+      ENDDO
+
+cIM BEG albedo LW
+        DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBLW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo LW de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,alblw(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,alblw(1,nsrf))
+#endif
+      ENDDO
+cIM END albedo LW
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Evaporation de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf))
+#endif
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Neige de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf))
+#endif
+      ENDDO
+
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Rayonnement net a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Rayonnement solaire a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27,
+     .                        "Rayonnement IF a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "Derive de flux")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,fder)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "precipitation liquide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                        "precipitation solide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall)
+#endif
+c
+       endif
+c$OMP END MASTER
+cc ----> necessaire pour eviter bug openMP sur SX6
+c$OMP MASTER
+      if (is_mpi_root) then
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "rugosite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_DOUBLE,1,idim2
+     $          ,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2
+     $          ,nvarid)
+#endif
+            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Age de la neige surface No."//str2)
+            ierr = NF_ENDDEF(nid)
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno(1,nsrf))
+#endif
+      ENDDO
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval)
+#endif
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Longueur de rugosite sur mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce))
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Eau liquide convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,clwcon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,clwcon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Nebulosite convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rnebcon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rnebcon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Ratqs")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ratqs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ratqs)
+#endif
+c
+c run_off_lic_0
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_DOUBLE,1,idim2,nvarid)
+#else
+      ierr=NF_DEF_VAR(nid,"RUNOFFLIC0",NF_FLOAT, 1,idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Runofflic0")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,run_off_lic_0)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,run_off_lic_0)
+#endif
+c
+c
+!!!!!!!!!!!!!!!!!!!! DEB TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+c
+      IF (iflag_pbl>1) then
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+            ierr = NF_DEF_VAR (nid,"TKE"//str2,NF_DOUBLE,1,idim3
+     $          ,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,"TKE"//str2,NF_FLOAT,1,idim3
+     $          ,nvarid)
+#endif
+            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Energ. Cineti. Turb."//str2)
+            ierr = NF_ENDDEF(nid)
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pbl_tke(:,:,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pbl_tke(:,:,nsrf))
+#endif
+      ENDDO
+      ENDIF
+
+!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+c
+      ierr = NF_CLOSE(nid)
+c
+      endif   ! is_mpi_root
+c$OMP END MASTER
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/physiq.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/physiq.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/physiq.F	(revision 984)
@@ -0,0 +1,3551 @@
+!
+! $Header$
+!
+c
+c#define IO_DEBUG
+
+      SUBROUTINE physiq (nlon,nlev,nqmax,
+     .            debut,lafin,rjourvrai,gmtime,pdtphys,
+     .            paprs,pplay,pphi,pphis,presnivs,clesphy0,
+     .            u,v,t,qx,
+     .            omega,
+#ifdef INCA
+     .            flxmass_w,
+#endif
+     .            d_u, d_v, d_t, d_qx, d_ps
+     .            , dudyn
+     .            , PVteta)
+
+      USE ioipsl
+      USE comgeomphy
+      USE write_field_phy
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE misc_mod, mydebug=>debug
+      USE vampir
+      USE pbl_surface_mod, ONLY : pbl_surface
+
+
+      USE ocean_slab_mod, ONLY   : ocean_slab_get_vars
+      USE ocean_cpl_mod, ONLY    : ocean_cpl_get_vars
+      USE ocean_forced_mod, ONLY : ocean_forced_get_vars
+      USE fonte_neige_mod, ONLY  : fonte_neige_get_vars
+
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c   CLEFS CPP POUR LES IO
+c   =====================
+c#define histhf
+#define histday
+#define histmth
+c#define histins
+c#define histmthNMC
+c#define histISCCP
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c nlon----input-I-nombre de points horizontaux
+c nlev----input-I-nombre de couches verticales
+c nqmax---input-I-nombre de traceurs (y compris vapeur d'eau) = 1
+c debut---input-L-variable logique indiquant le premier passage
+c lafin---input-L-variable logique indiquant le dernier passage
+c rjour---input-R-numero du jour de l'experience
+c gmtime--input-R-temps universel dans la journee (0 a 86400 s)
+c pdtphys-input-R-pas d'integration pour la physique (seconde)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
+c pphis---input-R-geopotentiel du sol
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+c u-------input-R-vitesse dans la direction X (de O a E) en m/s
+c v-------input-R-vitesse Y (de S a N) en m/s
+c t-------input-R-temperature (K)
+c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
+c d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
+c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
+c omega---input-R-vitesse verticale en Pa/s
+c d_u-----output-R-tendance physique de "u" (m/s/s)
+c d_v-----output-R-tendance physique de "v" (m/s/s)
+c d_t-----output-R-tendance physique de "t" (K/s)
+c d_qx----output-R-tendance physique de "qx" (kg/kg/s)
+c d_ps----output-R-tendance physique de la pression au sol
+cIM
+c PVteta--output-R-vorticite potentielle a des thetas constantes
+c======================================================================
+#include "dimensions.h"
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
+      integer iip1
+      parameter (iip1=iim+1)
+
+#include "regdim.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "logic.h"
+#include "temps.h"
+cym#include "comgeomphy.h"
+#include "advtrac.h"
+#include "iniprint.h"
+#include "thermcell.h"
+c======================================================================
+      LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
+      PARAMETER (ok_cvl=.TRUE.)
+      LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
+      PARAMETER (ok_gust=.FALSE.)
+c======================================================================
+      LOGICAL check ! Verifier la conservation du modele en eau
+      PARAMETER (check=.FALSE.)
+      LOGICAL ok_stratus ! Ajouter artificiellement les stratus
+      PARAMETER (ok_stratus=.FALSE.)
+c======================================================================
+      logical rnpb
+#ifdef INCA
+      parameter(rnpb=.false.)
+#else
+      parameter(rnpb=.true.)
+#endif
+c      ocean = type de modele ocean a utiliser: force, slab, couple
+      character*6 ocean
+      SAVE ocean
+c$OMP THREADPRIVATE(ocean)
+
+cIM "slab" ocean
+      REAL tslab(klon)    !Temperature du slab-ocean
+      REAL seaice(klon)   !glace de mer (kg/m2) 
+      REAL fluxo(klon)    !flux turbulents ocean-glace de mer 
+      REAL fluxg(klon)    !flux turbulents ocean-atmosphere
+      REAL amn, amx
+c======================================================================
+c Clef controlant l'activation du cycle diurne:
+ccc      LOGICAL cycle_diurne
+ccc      PARAMETER (cycle_diurne=.FALSE.)
+c======================================================================
+c Modele thermique du sol, a activer pour le cycle diurne:
+ccc      LOGICAL soil_model
+ccc      PARAMETER (soil_model=.FALSE.)
+      logical ok_veget
+      save ok_veget
+c$OMP THREADPRIVATE(ok_veget)
+c     parameter (ok_veget = .true.)
+c      parameter (ok_veget = .false.)
+c======================================================================
+c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
+c le calcul du rayonnement est celle apres la precipitation des nuages.
+c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
+c la condensation et la precipitation. Cette cle augmente les impacts
+c radiatifs des nuages.
+ccc      LOGICAL new_oliq
+ccc      PARAMETER (new_oliq=.FALSE.)
+c======================================================================
+c Clefs controlant deux parametrisations de l'orographie:
+cc      LOGICAL ok_orodr
+ccc      PARAMETER (ok_orodr=.FALSE.)
+ccc      LOGICAL ok_orolf
+ccc      PARAMETER (ok_orolf=.FALSE.)
+c======================================================================
+      LOGICAL ok_journe ! sortir le fichier journalier
+      save ok_journe
+c$OMP THREADPRIVATE(ok_journe)
+c
+      LOGICAL ok_mensuel ! sortir le fichier mensuel
+      save ok_mensuel
+c$OMP THREADPRIVATE(ok_mensuel)
+c
+      LOGICAL ok_instan ! sortir le fichier instantane
+      save ok_instan
+c$OMP THREADPRIVATE(ok_instan)
+c
+      LOGICAL ok_region ! sortir le fichier regional
+      PARAMETER (ok_region=.FALSE.)
+c======================================================================
+c     pour phsystoke avec thermiques
+      REAL fm_therm(klon,klev+1)
+      REAL entr_therm(klon,klev)
+      real,allocatable,save :: clwcon0th(:,:),rnebcon0th(:,:)
+c$OMP THREADPRIVATE(clwcon0th,rnebcon0th)
+
+      real weak_inversion(klon),dthmin(klon)
+      real seuil_inversion
+      save seuil_inversion
+c$OMP THREADPRIVATE(seuil_inversion)
+      integer iflag_ratqs
+      save iflag_ratqs
+c$OMP THREADPRIVATE(iflag_ratqs)
+
+      integer lmax_th(klon)
+      integer limbas(klon)
+      real ratqscth(klon,klev)
+      real ratqsdiff(klon,klev)
+      real zqsatth(klon,klev)
+
+c======================================================================
+c
+      INTEGER ivap          ! indice de traceurs pour vapeur d'eau
+      PARAMETER (ivap=1)
+      INTEGER iliq          ! indice de traceurs pour eau liquide
+      PARAMETER (iliq=2)
+
+c
+c
+c Variables argument:
+c
+      INTEGER nlon
+      INTEGER nlev
+      INTEGER nqmax
+      REAL rjourvrai
+      REAL gmtime
+      REAL pdtphys
+      LOGICAL debut, lafin
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      REAL pphis(klon)
+      REAL presnivs(klev)
+      REAL znivsig(klev)
+      real pir
+
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL t(klon,klev)
+      REAL qx(klon,klev,nqmax)
+
+      REAL,allocatable,save :: t_ancien(:,:), q_ancien(:,:)
+c$OMP THREADPRIVATE(t_ancien, q_ancien)
+      LOGICAL ancien_ok
+      SAVE ancien_ok
+c$OMP THREADPRIVATE(ancien_ok)
+      REAL d_t_dyn(klon,klev)
+      REAL d_q_dyn(klon,klev)
+
+      REAL omega(klon,klev)
+
+#ifdef INCA
+      REAL flxmass_w(klon,klev)
+#endif
+      REAL d_u(klon,klev)
+      REAL d_v(klon,klev)
+      REAL d_t(klon,klev)
+      REAL d_qx(klon,klev,nqmax)
+      REAL d_ps(klon)
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+c
+cIM Amip2 PV a theta constante 
+c
+      INTEGER nbteta
+      PARAMETER(nbteta=3)
+      CHARACTER*3 ctetaSTD(nbteta)
+      DATA ctetaSTD/'350','380','405'/
+      SAVE ctetaSTD
+c$OMP THREADPRIVATE(ctetaSTD)
+      REAL rtetaSTD(nbteta)
+      DATA rtetaSTD/350., 380., 405./
+      SAVE rtetaSTD
+c$OMP THREADPRIVATE(rtetaSTD)     
+c
+      REAL PVteta(klon,nbteta)
+      REAL zx_tmp_3dte(iim,jjmp1,nbteta)
+c
+cMI Amip2 PV a theta constante
+
+cym      INTEGER klevp1, klevm1
+cym      PARAMETER(klevp1=klev+1,klevm1=klev-1)
+cym#include "raddim.h"
+c
+
+      REAL,allocatable,save :: swdn0(:,:), swdn(:,:)
+      REAL,allocatable,save :: swup0(:,:), swup(:,:)
+c$OMP THREADPRIVATE(swdn0 , swdn, swup0, swup)
+c
+      REAL,allocatable,save :: SWdn200clr(:), SWdn200(:)
+      REAL,allocatable,save :: SWup200clr(:), SWup200(:)
+c$OMP THREADPRIVATE(SWdn200clr, SWdn200, SWup200clr, SWup200)
+c
+      REAL,allocatable,save :: lwdn0(:,:), lwdn(:,:)
+      REAL,allocatable,save :: lwup0(:,:), lwup(:,:)
+c$OMP THREADPRIVATE(lwdn0 , lwdn, lwup0, lwup)
+c
+      REAL,allocatable,save :: LWdn200clr(:), LWdn200(:)
+      REAL,allocatable,save :: LWup200clr(:), LWup200(:)
+c$OMP THREADPRIVATE(LWdn200clr, LWdn200, LWup200clr, LWup200)
+c
+      REAL,allocatable,save :: LWdnTOA(:), LWdnTOAclr(:)
+c$OMP THREADPRIVATE(LWdnTOA, LWdnTOAclr)
+c
+cIM Amip2
+c variables a une pression donnee
+c
+      integer nlevSTD
+      PARAMETER(nlevSTD=17)
+      real rlevSTD(nlevSTD)
+      DATA rlevSTD/100000., 92500., 85000., 70000.,
+     .60000., 50000., 40000., 30000., 25000., 20000.,
+     .15000., 10000., 7000., 5000., 3000., 2000., 1000./
+      SAVE rlevstd
+c$OMP THREADPRIVATE(rlevSTD)
+      CHARACTER*4 clevSTD(nlevSTD)
+      DATA clevSTD/'1000','925 ','850 ','700 ','600 ',
+     .'500 ','400 ','300 ','250 ','200 ','150 ','100 ',
+     .'70  ','50  ','30  ','20  ','10  '/
+      SAVE clevSTD
+c$OMP THREADPRIVATE(clevSTD)
+c
+      CHARACTER*3 bb2
+      CHARACTER*2 bb3
+c
+      real tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD)
+      real rhlevSTD(klon,nlevSTD), philevSTD(klon,nlevSTD)
+      real ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD)
+      real wlevSTD(klon,nlevSTD) 
+c
+c nout : niveau de output des variables a une pression donnee
+      INTEGER nout
+      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+c
+      REAL,SAVE,ALLOCATABLE :: tsumSTD(:,:,:)
+      REAL,SAVE,ALLOCATABLE :: usumSTD(:,:,:), vsumSTD(:,:,:)
+      REAL,SAVE,ALLOCATABLE :: wsumSTD(:,:,:), phisumSTD(:,:,:)
+      REAL,SAVE,ALLOCATABLE :: qsumSTD(:,:,:), rhsumSTD(:,:,:)
+c$OMP THREADPRIVATE(tsumSTD, usumSTD, vsumSTD, wsumSTD, phisumSTD) 
+c$OMP THREADPRIVATE(qsumSTD, rhsumSTD)
+c
+      logical oknondef(klon,nlevSTD,nout)
+      real,SAVE,ALLOCATABLE :: tnondef(:,:,:) 
+c$OMP THREADPRIVATE(tnondef)
+c
+c les produits uvSTD, vqSTD, .., T2STD sont calcules
+c a partir des valeurs instantannees toutes les 6 h
+c qui sont moyennees sur le mois
+c
+      real uvSTD(klon,nlevSTD)
+      real vqSTD(klon,nlevSTD)
+      real vTSTD(klon,nlevSTD)
+      real wqSTD(klon,nlevSTD)
+c
+      real,save,allocatable :: uvsumSTD(:,:,:)
+      real,save,allocatable :: vqsumSTD(:,:,:)
+      real,save,allocatable :: vTsumSTD(:,:,:)
+      real,save,allocatable :: wqsumSTD(:,:,:)
+c
+      real vphiSTD(klon,nlevSTD)
+      real wTSTD(klon,nlevSTD)
+      real u2STD(klon,nlevSTD)
+      real v2STD(klon,nlevSTD)
+      real T2STD(klon,nlevSTD)
+c
+      real,save,allocatable :: vphisumSTD(:,:,:)
+      real,save,allocatable :: wTsumSTD(:,:,:)
+      real,save,allocatable :: u2sumSTD(:,:,:)
+      real,save,allocatable :: v2sumSTD(:,:,:)
+      real,save,allocatable :: T2sumSTD(:,:,:)
+c
+c$OMP THREADPRIVATE(uvsumSTD, vqsumSTD, vTsumSTD, wqsumSTD)
+c$OMP THREADPRIVATE(vphisumSTD, wTsumSTD, u2sumSTD, v2sumSTD, T2sumSTD)
+
+cMI Amip2
+c
+#include "radepsi.h"
+#include "radopt.h"
+c
+c
+c prw: precipitable water
+      real prw(klon)
+
+      REAL convliq(klon,klev)  ! eau liquide nuageuse convective
+      REAL convfra(klon,klev)  ! fraction nuageuse convective
+
+      REAL cldl_c(klon),cldm_c(klon),cldh_c(klon) !nuages bas, moyen et haut
+      REAL cldt_c(klon),cldq_c(klon) !nuage total, eau liquide integree
+      REAL cldl_s(klon),cldm_s(klon),cldh_s(klon) !nuages bas, moyen et haut
+      REAL cldt_s(klon),cldq_s(klon) !nuage total, eau liquide integree
+
+      INTEGER linv, kp1
+c flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2)
+c flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg)
+      REAL flwp(klon), fiwp(klon)
+      REAL flwc(klon,klev), fiwc(klon,klev)
+      REAL flwp_c(klon), fiwp_c(klon)
+      REAL flwc_c(klon,klev), fiwc_c(klon,klev)
+      REAL flwp_s(klon), fiwp_s(klon)
+      REAL flwc_s(klon,klev), fiwc_s(klon,klev)
+
+cIM ISCCP simulator v3.4
+c dans clesphys.h top_height, overlap
+cv3.4
+      INTEGER debug, debugcol
+cym      INTEGER npoints
+cym      PARAMETER(npoints=klon) 
+c
+      INTEGER sunlit(klon) !sunlit=1 if day; sunlit=0 if night
+      INTEGER nregISCtot
+      PARAMETER(nregISCtot=1) 
+c
+c imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire
+c y compris pour 1 point
+c imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude)
+c jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude)
+      INTEGER imin_debut, nbpti
+      INTEGER jmin_debut, nbptj 
+cIM parametres ISCCP BEG
+      INTEGER nbapp_isccp
+!     INTEGER nbapp_isccp,isccppas
+!     PARAMETER(isccppas=6) !appel du simulateurs tous les 6pas de temps de la physique
+!                           !i.e. toutes les 3 heures 
+      INTEGER n, napisccp
+c     PARAMETER(napisccp=3)
+      PARAMETER(napisccp=1)
+      INTEGER ifreq_isccp(napisccp), freqin_pdt(napisccp)
+      DATA ifreq_isccp/3/
+      SAVE ifreq_isccp
+c$OMP THREADPRIVATE(ifreq_isccp)
+      CHARACTER*5 typinout(napisccp)
+      DATA typinout/'i3od'/
+      SAVE typinout
+c$OMP THREADPRIVATE(typinout)
+cIM verif boxptop BEG
+      CHARACTER*1 verticaxe(napisccp)
+      DATA verticaxe/'1'/ 
+      SAVE verticaxe
+c$OMP THREADPRIVATE(verticaxe)
+cIM verif boxptop END
+      INTEGER nvlev(napisccp)
+c     INTEGER nvlev
+      REAL t1, aa
+      REAL seed_re(klon,napisccp)
+      INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:)
+c$OMP THREADPRIVATE(seed_old)
+cym !!!! A voir plus tard 
+cym      INTEGER iphy(iim,jjmp1)
+cIM parametres ISCCP END
+c
+c ncol = nb. de sous-colonnes pour chaque maille du GCM 
+c ncolmx = No. max. de sous-colonnes pour chaque maille du GCM 
+c      INTEGER ncol(napisccp), ncolmx, seed(klon,napisccp)
+      INTEGER,SAVE :: ncol(napisccp)
+      INTEGER ncolmx, seed(klon,napisccp)
+      REAL nbsunlit(nregISCtot,klon,napisccp)  !nbsunlit : moyenne de sunlit
+c     PARAMETER(ncolmx=1500)
+      PARAMETER(ncolmx=300)
+c
+cIM verif boxptop BEG
+      REAL vertlev(ncolmx,napisccp)
+cIM verif boxptop END
+c
+      REAL,SAVE :: tautab_omp(0:255),tautab(0:255)
+      INTEGER,SAVE :: invtau_omp(-20:45000),invtau(-20:45000)
+c$OMP THREADPRIVATE(tautab,invtau)
+      REAL emsfc_lw
+      PARAMETER(emsfc_lw=0.99)
+c     REAL    ran0                      ! type for random number fuction
+c
+      REAL cldtot(klon,klev)
+c variables de haut en bas pour le simulateur ISCCP
+      REAL dtau_s(klon,klev) !tau nuages startiformes
+      REAL dtau_c(klon,klev) !tau nuages convectifs
+      REAL dem_s(klon,klev)  !emissivite nuages startiformes 
+      REAL dem_c(klon,klev)  !emissivite nuages convectifs
+c
+c variables de haut en bas pour le simulateur ISCCP
+      REAL pfull(klon,klev)
+      REAL phalf(klon,klev+1)
+      REAL qv(klon,klev)
+      REAL cc(klon,klev)
+      REAL conv(klon,klev)
+      REAL dtau_sH2B(klon,klev)
+      REAL dtau_cH2B(klon,klev)
+      REAL at(klon,klev)
+      REAL dem_sH2B(klon,klev)
+      REAL dem_cH2B(klon,klev)
+c
+      INTEGER kmax, lmax, lmax3
+      PARAMETER(kmax=8, lmax=8, lmax3=3)
+      INTEGER kmaxm1, lmaxm1
+      PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1)
+      INTEGER iimx7, jjmx7, jjmp1x7
+      PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1, 
+     .jjmp1x7=jjmp1*lmaxm1)
+c
+c output from ISCCP simulator
+      REAL fq_isccp(klon,kmaxm1,lmaxm1,napisccp)
+      REAL fq_is_true(klon,kmaxm1,lmaxm1,napisccp)
+      REAL totalcldarea(klon,napisccp) 
+      REAL meanptop(klon,napisccp)
+      REAL meantaucld(klon,napisccp)
+      REAL boxtau(klon,ncolmx,napisccp)
+      REAL boxptop(klon,ncolmx,napisccp) 
+      REAL zx_tmp_fi3d_bx(klon,ncolmx)
+      REAL zx_tmp_3d_bx(iim,jjmp1,ncolmx)
+c
+      REAL cld_fi3d(klon,lmax3)
+      REAL cld_3d(iim,jjmp1,lmax3)
+c
+      INTEGER iw, iwmax
+      REAL wmin, pas_w
+c     PARAMETER(wmin=-100.,pas_w=10.,iwmax=30)
+cIM 051005     PARAMETER(wmin=-200.,pas_w=10.,iwmax=40)
+      PARAMETER(wmin=-100.,pas_w=10.,iwmax=20)
+      REAL o500(klon)
+c
+cIM: nbregdyn = nbre regions pour calculs statistiques sur output du ISCCP
+cIM: dynamiques  
+      INTEGER nreg, nbregdyn
+      PARAMETER(nbregdyn=5)
+
+      INTEGER,ALLOCATABLE,SAVE :: pct_ocean(:,:)
+c$OMP THREADPRIVATE(pct_ocean)
+cym      SAVE pct_ocean
+ 
+c sorties ISCCP
+
+      integer nid_isccp
+      save nid_isccp        
+c$OMP THREADPRIVATE(nid_isccp)
+
+      REAL zx_tau(kmaxm1), zx_pc(lmaxm1), zx_o500(iwmax)
+      DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./
+      SAVE zx_tau
+      DATA zx_pc/180., 310., 440., 560., 680., 800., 1000./
+      SAVE zx_pc
+c$OMP THREADPRIVATE(zx_tau,zx_pc)
+c cldtopres pression au sommet des nuages
+      REAL cldtopres(lmaxm1), cldtopres3(lmax3)
+      DATA cldtopres/180., 310., 440., 560., 680., 800., 1000./
+      DATA cldtopres3/440., 680., 1000./
+      SAVE cldtopres,cldtopres3
+c$OMP THREADPRIVATE(cldtopres,cldtopres3)
+cIM 051005 BEG
+      REAL tmp_his1_3d(iwmax,kmaxm1,lmaxm1,nbregdyn,napisccp) 
+      REAL tmp_his2_3d(iwmax,kmaxm1,lmaxm1,nbregdyn,napisccp) 
+      REAL tmp_his3_3d(iwmax,kmaxm1,lmaxm1,nbregdyn,napisccp) 
+      INTEGER komega, nhoriRD 
+
+c taulev: numero du niveau de tau dans les sorties ISCCP
+      CHARACTER *4 taulev(kmaxm1)
+c     DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/
+      DATA taulev/'tau0','tau1','tau2','tau3','tau4','tau5','tau6'/
+      CHARACTER *3 pclev(lmaxm1)
+      DATA pclev/'pc1','pc2','pc3','pc4','pc5','pc6','pc7'/
+      SAVE taulev,pclev
+c$OMP THREADPRIVATE(taulev,pclev)
+c
+c cnameisccp
+      CHARACTER *27 cnameisccp(lmaxm1,kmaxm1)
+cIM bad 151205     DATA cnameisccp/'pc< 50hPa, tau< 0.3', 
+      DATA cnameisccp/'pc= 50-180hPa, tau< 0.3',
+     .                'pc= 180-310hPa, tau< 0.3',
+     .                'pc= 310-440hPa, tau< 0.3',
+     .                'pc= 440-560hPa, tau< 0.3',
+     .                'pc= 560-680hPa, tau< 0.3',
+     .                'pc= 680-800hPa, tau< 0.3',
+     .                'pc= 800-1000hPa, tau< 0.3',
+     .                'pc= 50-180hPa, tau= 0.3-1.3',
+     .                'pc= 180-310hPa, tau= 0.3-1.3',
+     .                'pc= 310-440hPa, tau= 0.3-1.3',
+     .                'pc= 440-560hPa, tau= 0.3-1.3',
+     .                'pc= 560-680hPa, tau= 0.3-1.3',
+     .                'pc= 680-800hPa, tau= 0.3-1.3',
+     .                'pc= 800-1000hPa, tau= 0.3-1.3',
+     .                'pc= 50-180hPa, tau= 1.3-3.6',
+     .                'pc= 180-310hPa, tau= 1.3-3.6',
+     .                'pc= 310-440hPa, tau= 1.3-3.6',
+     .                'pc= 440-560hPa, tau= 1.3-3.6',
+     .                'pc= 560-680hPa, tau= 1.3-3.6',
+     .                'pc= 680-800hPa, tau= 1.3-3.6',
+     .                'pc= 800-1000hPa, tau= 1.3-3.6',
+     .                'pc= 50-180hPa, tau= 3.6-9.4',
+     .                'pc= 180-310hPa, tau= 3.6-9.4',
+     .                'pc= 310-440hPa, tau= 3.6-9.4',
+     .                'pc= 440-560hPa, tau= 3.6-9.4',
+     .                'pc= 560-680hPa, tau= 3.6-9.4',
+     .                'pc= 680-800hPa, tau= 3.6-9.4',
+     .                'pc= 800-1000hPa, tau= 3.6-9.4',
+     .                'pc= 50-180hPa, tau= 9.4-23',
+     .                'pc= 180-310hPa, tau= 9.4-23',
+     .                'pc= 310-440hPa, tau= 9.4-23',
+     .                'pc= 440-560hPa, tau= 9.4-23',
+     .                'pc= 560-680hPa, tau= 9.4-23',
+     .                'pc= 680-800hPa, tau= 9.4-23',
+     .                'pc= 800-1000hPa, tau= 9.4-23',
+     .                'pc= 50-180hPa, tau= 23-60',
+     .                'pc= 180-310hPa, tau= 23-60',
+     .                'pc= 310-440hPa, tau= 23-60',
+     .                'pc= 440-560hPa, tau= 23-60',
+     .                'pc= 560-680hPa, tau= 23-60',
+     .                'pc= 680-800hPa, tau= 23-60',
+     .                'pc= 800-1000hPa, tau= 23-60',
+     .                'pc= 50-180hPa, tau> 60.',
+     .                'pc= 180-310hPa, tau> 60.',
+     .                'pc= 310-440hPa, tau> 60.',
+     .                'pc= 440-560hPa, tau> 60.',
+     .                'pc= 560-680hPa, tau> 60.',
+     .                'pc= 680-800hPa, tau> 60.',
+     .                'pc= 800-1000hPa, tau> 60.'/
+       SAVE cnameisccp
+c$OMP THREADPRIVATE(cnameisccp)
+c
+c     REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7)
+c     INTEGER nhorix7
+cIM: region='3d' <==> sorties en global
+      CHARACTER*3 region
+      PARAMETER(region='3d')
+c
+cIM ISCCP simulator v3.4
+c
+      logical ok_hf
+c
+      integer nid_hf, nid_hf3d
+      save ok_hf, nid_hf, nid_hf3d
+c$OMP THREADPRIVATE(ok_hf, nid_hf, nid_hf3d)
+c  QUESTION : noms de variables ?
+
+c#ifdef histhf
+c      data ok_hf/.true./
+c#else
+c      data ok_hf/.false./
+c#endif
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles      )
+c
+c Variables quasi-arguments
+c
+      REAL xjour
+      SAVE xjour
+c$OMP THREADPRIVATE(xjour)
+c
+c
+c Variables propres a la physique
+c
+      REAL dtime
+      SAVE dtime                  ! pas temporel de la physique
+c$OMP THREADPRIVATE(dtime)
+c
+      INTEGER radpas
+      SAVE radpas                 ! frequence d'appel rayonnement
+c$OMP THREADPRIVATE(radpas)
+c
+      REAL,allocatable,save :: radsol(:)
+c$OMP THREADPRIVATE(radsol)
+cym      SAVE radsol               ! bilan radiatif au sol calcule par code radiatif
+c
+      REAL,allocatable,save :: rlat(:)
+c$OMP THREADPRIVATE(rlat)
+cym      SAVE rlat                   ! latitude pour chaque point
+c
+      REAL,allocatable,save :: rlon(:)
+c$OMP THREADPRIVATE(rlon)
+cym      SAVE rlon                   ! longitude pour chaque point
+
+      REAL,SAVE,ALLOCATABLE :: rlonPOS(:)
+c$OMP THREADPRIVATE(rlonPOS)    
+cym      SAVE rlonPOS                ! longitudes > 0. pour chaque point
+c
+cc      INTEGER iflag_con
+cc      SAVE iflag_con              ! indicateur de la convection
+c
+      INTEGER itap
+      SAVE itap                   ! compteur pour la physique
+c$OMP THREADPRIVATE(itap)
+c
+      REAL co2_ppm_etat0
+c
+      REAL solaire_etat0
+c
+      real slp(klon) ! sea level pressure
+
+      REAL,allocatable,save :: ftsol(:,:)
+c$OMP THREADPRIVATE(ftsol)       ! temperature du sol
+
+cIM
+      REAL,SAVE,ALLOCATABLE :: newsst(:) !temperature de l'ocean
+c$OMP THREADPRIVATE(newsst)
+cym     SAVE newsst
+c
+      REAL fevap(klon,nbsrf)
+      REAL fluxlat(klon,nbsrf)
+c
+      REAL,allocatable,save :: deltat(:)
+c$OMP THREADPRIVATE(deltat)
+cym      SAVE deltat                 ! ecart avec la SST de reference
+c
+      REAL qsol(klon)
+c
+      REAL,allocatable,save :: falbe(:,:)
+c$OMP THREADPRIVATE(falbe)       ! albedo par type de surface
+c
+      REAL,allocatable,save :: falblw(:,:)
+c$OMP THREADPRIVATE(falblw)       ! albedo par type de surface
+
+c
+c
+c  Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
+c
+      REAL,allocatable,save :: zmea(:)
+c$OMP THREADPRIVATE(zmea)
+cym      SAVE zmea                   ! orographie moyenne
+c
+      REAL,allocatable,save :: zstd(:)
+c$OMP THREADPRIVATE(zstd)
+cym      SAVE zstd                   ! deviation standard de l'OESM
+c
+      REAL,allocatable,save :: zsig(:)
+c$OMP THREADPRIVATE(zsig)
+cym      SAVE zsig                   ! pente de l'OESM
+c
+      REAL,allocatable,save :: zgam(:)
+c$OMP THREADPRIVATE(zgam)
+cym      save zgam                   ! anisotropie de l'OESM
+c
+      REAL,allocatable,save :: zthe(:)
+c$OMP THREADPRIVATE(zthe)      
+cym      SAVE zthe                   ! orientation de l'OESM
+c
+      REAL,allocatable,save :: zpic(:)
+c$OMP THREADPRIVATE(zpic)
+cym      SAVE zpic                   ! Maximum de l'OESM
+c
+      REAL,allocatable,save :: zval(:)
+c$OMP THREADPRIVATE(zval)
+cym      SAVE zval                   ! Minimum de l'OESM
+c
+      REAL,allocatable,save :: rugoro(:)
+c$OMP THREADPRIVATE(rugoro)
+cym      SAVE rugoro                 ! longueur de rugosite de l'OESM
+c
+cIM 141004     REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
+      REAL zulow(klon),zvlow(klon)
+c
+      REAL,allocatable,save :: zuthe(:),zvthe(:)
+c$OMP THREADPRIVATE(zuthe,zvthe)
+cym      SAVE zuthe
+cym      SAVE zvthe
+      INTEGER igwd,idx(klon),itest(klon)
+c
+      REAL agesno(klon,nbsrf)
+c
+      REAL,allocatable,save :: alb_neig(:)
+c$OMP THREADPRIVATE(alb_neig)
+cym      SAVE alb_neig               ! albedo de la neige
+c
+c      REAL,allocatable,save :: run_off_lic_0(:)
+cc$OMP THREADPRIVATE(run_off_lic_0)
+cym      SAVE run_off_lic_0
+cKE43
+c Variables liees a la convection de K. Emanuel (sb):
+c
+      REAL,allocatable,save :: ema_workcbmf(:)   ! cloud base mass flux
+c$OMP THREADPRIVATE(ema_workcbmf)
+cym      SAVE ema_workcbmf
+
+      REAL,allocatable,save :: ema_cbmf(:)       ! cloud base mass flux
+c$OMP THREADPRIVATE(ema_cbmf)
+cym      SAVE ema_cbmf
+
+      REAL,allocatable,save :: ema_pcb(:)        ! cloud base pressure
+c$OMP THREADPRIVATE(ema_pcb)
+cym      SAVE ema_pcb
+
+      REAL,allocatable,save :: ema_pct(:)        ! cloud top pressure
+c$OMP THREADPRIVATE(ema_pct)
+cym      SAVE ema_pct
+
+      REAL bas, top             ! cloud base and top levels
+      SAVE bas
+      SAVE top
+c$OMP THREADPRIVATE(bas, top)
+
+      REAL,allocatable,save :: Ma(:,:)        ! undilute upward mass flux
+c$OMP THREADPRIVATE(Ma)
+cym      SAVE Ma
+      REAL,allocatable,save :: qcondc(:,:)    ! in-cld water content from convect
+c$OMP THREADPRIVATE(qcondc)
+cym      SAVE qcondc 
+      REAL,allocatable,save :: ema_work1(:, :), ema_work2(:, :)
+c$OMP THREADPRIVATE(ema_work1,ema_work2)
+cym      SAVE ema_work1, ema_work2
+      REAL wdn(klon), tdn(klon), qdn(klon)
+
+      REAL,allocatable,save :: wd(:) ! sb
+c$OMP THREADPRIVATE(wd)
+cym      SAVE wd       ! sb
+
+c Variables locales pour la couche limite (al1):
+c
+cAl1      REAL pblh(klon)           ! Hauteur de couche limite
+cAl1      SAVE pblh
+c34EK
+c
+c Variables locales:
+c
+      REAL cdragh(klon) ! drag coefficient pour T and Q
+      REAL cdragm(klon) ! drag coefficient pour vent
+cAA
+cAA  Pour phytrac 
+cAA
+      REAL ycoefh(klon,klev)    ! coef d'echange pour phytrac
+      REAL yu1(klon)            ! vents dans la premiere couche U
+      REAL yv1(klon)            ! vents dans la premiere couche V
+
+      REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon)
+
+c@$$      LOGICAL offline           ! Controle du stockage ds "physique"
+c@$$      PARAMETER (offline=.false.)
+c@$$      INTEGER physid
+      REAL,allocatable,save :: pfrac_impa(:,:)! Produits des coefs lessivage impaction
+c$OMP THREADPRIVATE(pfrac_impa)
+cym      save pfrac_impa
+      REAL,allocatable,save :: pfrac_nucl(:,:)! Produits des coefs lessivage nucleation
+c$OMP THREADPRIVATE(pfrac_nucl)
+cym      save pfrac_nucl
+      REAL,allocatable,save :: pfrac_1nucl(:,:)! Produits des coefs lessi nucl (alpha = 1)
+c$OMP THREADPRIVATE(pfrac_1nucl)
+cym      save pfrac_1nucl
+      REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
+      REAL frac_nucl(klon,klev) ! idem (nucleation)
+#ifdef INCA
+      INTEGER       :: iii
+      REAL          :: calday
+#endif
+
+cAA
+      REAL,allocatable,save :: rain_fall(:) ! pluie
+c$OMP THREADPRIVATE(rain_fall)
+      REAL,allocatable,save :: snow_fall(:) ! neige
+c$OMP THREADPRIVATE(snow_fall)
+cym      save snow_fall, rain_fall
+
+cIM cf FH pour Tiedtke 080604
+      REAL rain_tiedtke(klon),snow_tiedtke(klon)
+c
+
+      REAL,allocatable,save :: total_rain(:), nday_rain(:)
+c$OMP THREADPRIVATE(total_rain,nday_rain)
+cym      save total_rain, nday_rain
+cIM 050204 END
+      REAL evap(klon), devap(klon) ! evaporation et sa derivee
+      REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
+
+      REAL bils(klon) ! bilan de chaleur au sol
+      REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque
+C                             ! type de sous-surface et pondere par la fraction
+      REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque
+C                             ! type de sous-surface et pondere par la fraction
+      REAL fder(klon)         
+      REAL ve(klon) ! integr. verticale du transport meri. de l'energie
+      REAL vq(klon) ! integr. verticale du transport meri. de l'eau
+      REAL ue(klon) ! integr. verticale du transport zonal de l'energie
+      REAL uq(klon) ! integr. verticale du transport zonal de l'eau
+c
+      REAL frugs(klon,nbsrf)
+      REAL zxrugs(klon) ! longueur de rugosite
+c
+c Conditions aux limites
+c
+      INTEGER julien
+c
+      INTEGER lmt_pas
+      SAVE lmt_pas                ! frequence de mise a jour
+c$OMP THREADPRIVATE(lmt_pas) 
+      REAL,allocatable,save :: pctsrf(:,:)
+c$OMP THREADPRIVATE(pctsrf) 
+cIM
+      REAL pctsrf_new(klon,nbsrf) !pourcentage surfaces issus d'ORCHIDEE
+
+cym      REAL paire_ter(klon)        !surfaces terre 
+      REAL,allocatable,save ::  paire_ter(:)        !surfaces terre 
+c$OMP THREADPRIVATE(paire_ter) 
+    
+cIM
+cym      SAVE pctsrf                 ! sous-fraction du sol
+      REAL,allocatable,save :: albsol(:)
+c$OMP THREADPRIVATE(albsol)
+cym      SAVE albsol                 ! albedo du sol total
+      REAL,allocatable,save :: albsollw(:)
+c$OMP THREADPRIVATE(albsollw)      
+cym      SAVE albsollw                 ! albedo du sol total
+
+      REAL,allocatable,save :: wo(:,:)
+c$OMP THREADPRIVATE(wo)
+cym     SAVE wo                     ! ozone
+
+cIM sorties
+      REAL un_jour
+      PARAMETER(un_jour=86400.)
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+      EXTERNAL angle     ! calculer angle zenithal du soleil
+      EXTERNAL alboc     ! calculer l'albedo sur ocean
+      EXTERNAL ajsec     ! ajustement sec
+      EXTERNAL conlmd    ! convection (schema LMD)
+cKE43
+      EXTERNAL conema3  ! convect4.3
+      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
+cAA 
+      EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
+c                          ! stockage des coefficients necessaires au
+c                          ! lessivage OFF-LINE et ON-LINE
+      EXTERNAL hgardfou  ! verifier les temperatures
+      EXTERNAL nuage     ! calculer les proprietes radiatives
+      EXTERNAL o3cm      ! initialiser l'ozone
+      EXTERNAL orbite    ! calculer l'orbite terrestre
+      EXTERNAL ozonecm   ! prescrire l'ozone
+      EXTERNAL phyetat0  ! lire l'etat initial de la physique
+      EXTERNAL phyredem  ! ecrire l'etat de redemarrage de la physique
+      EXTERNAL radlwsw   ! rayonnements solaire et infrarouge
+      EXTERNAL suphec    ! initialiser certaines constantes
+      EXTERNAL transp    ! transport total de l'eau et de l'energie
+      EXTERNAL ecribina  ! ecrire le fichier binaire global
+      EXTERNAL ecribins  ! ecrire le fichier binaire global
+      EXTERNAL ecrirega  ! ecrire le fichier binaire regional
+      EXTERNAL ecriregs  ! ecrire le fichier binaire regional
+cIM
+      EXTERNAL haut2bas  !variables de haut en bas
+      INTEGER lnblnk1
+      EXTERNAL lnblnk1   !enleve les blancs a la fin d'une variable de type
+                         !caracter
+      EXTERNAL ini_undefSTD  !initialise a 0 une variable a 1 niveau de pression
+      EXTERNAL undefSTD      !somme les valeurs definies d'1 var a 1 niveau de pression
+c     EXTERNAL moy_undefSTD  !moyenne d'1 var a 1 niveau de pression
+c     EXTERNAL moyglo_aire   !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire)
+c                            !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
+c
+c Variables locales
+c
+      real,allocatable,save :: clwcon(:,:),rnebcon(:,:)
+c$OMP THREADPRIVATE(clwcon,rnebcon)
+      real,allocatable,save :: clwcon0(:,:),rnebcon0(:,:)
+cym      save rnebcon, clwcon
+c$OMP THREADPRIVATE(clwcon0,rnebcon0)
+      REAL rhcl(klon,klev)    ! humiditi relative ciel clair
+      REAL dialiq(klon,klev)  ! eau liquide nuageuse
+      REAL diafra(klon,klev)  ! fraction nuageuse
+      REAL cldliq(klon,klev)  ! eau liquide nuageuse
+      REAL cldfra(klon,klev)  ! fraction nuageuse
+      REAL cldtau(klon,klev)  ! epaisseur optique
+      REAL cldemi(klon,klev)  ! emissivite infrarouge
+c
+CXXX PB 
+      REAL fluxq(klon,klev, nbsrf)   ! flux turbulent d'humidite
+      REAL fluxt(klon,klev, nbsrf)   ! flux turbulent de chaleur
+      REAL fluxu(klon,klev, nbsrf)   ! flux turbulent de vitesse u
+      REAL fluxv(klon,klev, nbsrf)   ! flux turbulent de vitesse v
+
+      REAL, DIMENSION(:,:,:), ALLOCATABLE, SAVE :: pbl_tke ! turb kinetic energy
+c   !$OMP THREADPRIVATE(pbl_tke)
+
+c
+      REAL zxfluxt(klon, klev)
+      REAL zxfluxq(klon, klev)
+      REAL zxfluxu(klon, klev)
+      REAL zxfluxv(klon, klev)
+CXXX
+      REAL,allocatable,save :: heat(:,:)    ! chauffage solaire
+c$OMP THREADPRIVATE(heat)
+      REAL,allocatable,save :: heat0(:,:)   ! chauffage solaire ciel clair
+c$OMP THREADPRIVATE(heat0)
+      REAL,allocatable,save :: cool(:,:)    ! refroidissement infrarouge
+c$OMP THREADPRIVATE(cool)
+      REAL,allocatable,save :: cool0(:,:)   ! refroidissement infrarouge ciel clair
+c$OMP THREADPRIVATE(cool0)
+      REAL,allocatable,save :: topsw(:), toplw(:), solsw(:), sollw(:)
+c$OMP THREADPRIVATE(topsw,toplw,solsw,sollw)
+      real,allocatable,save :: sollwdown(:)    ! downward LW flux at surface
+c$OMP THREADPRIVATE(sollwdown)
+cIM BEG
+      real,allocatable,save :: sollwdownclr(:)    ! downward CS LW flux at surface 
+c$OMP THREADPRIVATE(sollwdownclr)
+      real,allocatable,save :: toplwdown(:)       ! downward CS LW flux at TOA
+c$OMP THREADPRIVATE(toplwdown)
+      real,allocatable,save :: toplwdownclr(:)    ! downward CS LW flux at TOA
+c$OMP THREADPRIVATE(toplwdownclr)
+cIM END
+      REAL,allocatable,save :: topsw0(:),toplw0(:),solsw0(:),sollw0(:)
+c$OMP THREADPRIVATE( topsw0,toplw0,solsw0,sollw0)
+      REAL,allocatable,save :: albpla(:)
+c$OMP THREADPRIVATE(albpla)
+      REAL fsollw(klon, nbsrf)   ! bilan flux IR pour chaque sous surface
+      REAL fsolsw(klon, nbsrf)   ! flux solaire absorb. pour chaque sous surface
+c Le rayonnement n'est pas calcule tous les pas, il faut donc
+c                      sauvegarder les sorties du rayonnement
+cym      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
+cym      SAVE  sollwdownclr, toplwdown, toplwdownclr
+cym      SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
+c
+      INTEGER itaprad
+      SAVE itaprad
+c$OMP THREADPRIVATE(itaprad)
+c
+      REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
+      REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
+c
+      REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut
+      REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
+c
+      REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon)
+      REAL zxsnow_dummy(klon)
+c
+      REAL dist, rmu0(klon), fract(klon)
+      REAL zdtime, zlongi
+c
+      CHARACTER*2 str2
+      CHARACTER*2 iqn
+c
+      REAL qcheck
+      REAL z_avant(klon), z_apres(klon), z_factor(klon)
+      LOGICAL zx_ajustq
+c
+      REAL za, zb
+      REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
+      real zqsat(klon,klev)
+      INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zphi(klon,klev)
+cym A voir plus tard !!
+cym      REAL zx_relief(iim,jjmp1)
+cym      REAL zx_aire(iim,jjmp1)
+c
+c Grandeurs de sorties
+      REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)
+      REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)
+      REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon)
+      REAL s_trmb3(klon)
+cKE43
+c Variables locales pour la convection de K. Emanuel (sb):
+c
+      REAL upwd(klon,klev)      ! saturated updraft mass flux
+      REAL dnwd(klon,klev)      ! saturated downdraft mass flux
+      REAL dnwd0(klon,klev)     ! unsaturated downdraft mass flux
+      REAL tvp(klon,klev)       ! virtual temp of lifted parcel
+      REAL,allocatable,save :: cape(:)           ! CAPE
+c$OMP THREADPRIVATE(cape)
+cym      SAVE cape
+      CHARACTER*40 capemaxcels  !max(CAPE)
+
+      REAL,allocatable,save :: pbase(:)          ! cloud base pressure
+c$OMP THREADPRIVATE(pbase)
+cym      SAVE pbase
+      REAL,allocatable,save :: bbase(:)          ! cloud base buoyancy
+c$OMP THREADPRIVATE(bbase)
+cym      SAVE bbase
+      REAL rflag(klon)          ! flag fonctionnement de convect
+      INTEGER iflagctrl(klon)          ! flag fonctionnement de convect
+c -- convect43:
+      INTEGER ntra              ! nb traceurs pour convect4.3
+      REAL pori_con(klon)    ! pressure at the origin level of lifted parcel
+      REAL plcl_con(klon),dtma_con(klon),dtlcl_con(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+c?     .     condm_con(klon,klev),conda_con(klon,klev),
+c?     .     mr_con(klon,klev),ep_con(klon,klev)
+c?     .    ,sadiab(klon,klev),wadiab(klon,klev)
+c --
+c34EK
+c
+c Variables du changement
+c
+c con: convection
+c lsc: condensation a grande echelle (Large-Scale-Condensation)
+c ajs: ajustement sec
+c eva: evaporation de l'eau liquide nuageuse
+c vdf: couche limite (Vertical DiFfusion)
+      REAL d_t_con(klon,klev),d_q_con(klon,klev)
+      REAL,SAVE,ALLOCATABLE :: d_u_con(:,:),d_v_con(:,:)
+c$OMP THREADPRIVATE(d_u_con,d_v_con)
+      REAL d_t_lsc(klon,klev),d_q_lsc(klon,klev),d_ql_lsc(klon,klev)
+      REAL d_t_ajsb(klon,klev), d_q_ajsb(klon,klev)
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_u_ajs(klon,klev), d_v_ajs(klon,klev)
+      REAL d_t_eva(klon,klev),d_q_eva(klon,klev)
+      REAL d_t_oli(klon,klev) !tendances dues a oro et lif 
+      REAL rneb(klon,klev)
+c
+*********************************************************
+*     declarations
+      real,save,allocatable :: zqasc(:,:)
+c$OMP THREADPRIVATE(zqasc)
+cym      save zqasc
+      
+*********************************************************
+cIM 081204 END
+c
+      REAL pmfu(klon,klev), pmfd(klon,klev)
+      REAL pen_u(klon,klev), pen_d(klon,klev)
+      REAL pde_u(klon,klev), pde_d(klon,klev)
+      INTEGER kcbot(klon), kctop(klon), kdtop(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      REAL prfl(klon,klev+1), psfl(klon,klev+1)
+c
+      INTEGER,allocatable,save :: ibas_con(:), itop_con(:)
+c$OMP THREADPRIVATE(ibas_con,itop_con)
+cym
+cym      SAVE ibas_con,itop_con
+cym
+      REAL,SAVE,ALLOCATABLE :: rain_con(:)
+c$OMP THREADPRIVATE(rain_con)
+      REAL rain_lsc(klon)
+      REAL,SAVE,ALLOCATABLE :: snow_con(:)
+c$OMP THREADPRIVATE(snow_con)
+      REAL snow_lsc(klon)
+      REAL d_ts(klon,nbsrf)
+c
+      REAL d_u_vdf(klon,klev), d_v_vdf(klon,klev)
+      REAL d_t_vdf(klon,klev), d_q_vdf(klon,klev)
+c
+      REAL d_u_oro(klon,klev), d_v_oro(klon,klev)
+      REAL d_t_oro(klon,klev)
+      REAL d_u_lif(klon,klev), d_v_lif(klon,klev)
+      REAL d_t_lif(klon,klev)
+      REAL d_u_oli(klon,klev), d_v_oli(klon,klev) !tendances dues a oro et lif 
+
+      REAL,allocatable,save :: ratqs(:,:)
+c$OMP THREADPRIVATE(ratqs)
+      REAL ratqss(klon,klev),ratqsc(klon,klev)
+      real ratqsbas,ratqshaut
+cym      save ratqsbas,ratqshaut, ratqs
+      save ratqsbas,ratqshaut
+c$OMP THREADPRIVATE(ratqsbas,ratqshaut)
+      real zpt_conv(klon,klev)
+
+c Parametres lies au nouveau schema de nuages (SB, PDF)
+      real fact_cldcon
+      real facttemps
+      logical ok_newmicro
+      save ok_newmicro
+c$OMP THREADPRIVATE(ok_newmicro)
+      save fact_cldcon,facttemps
+c$OMP THREADPRIVATE(fact_cldcon,facttemps)
+      real facteur
+
+      integer iflag_cldcon
+      save iflag_cldcon
+c$OMP THREADPRIVATE(iflag_cldcon)
+      logical ptconv(klon,klev)
+cIM cf. AM 081204 BEG
+      logical ptconvth(klon,klev)
+cIM cf. AM 081204 END
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c======================================================================
+c
+cIM cf. AM 081204 BEG
+c   declarations pour sortir sur une sous-region
+      integer imin_ins,imax_ins,jmin_ins,jmax_ins
+      save imin_ins,imax_ins,jmin_ins,jmax_ins
+c$OMP THREADPRIVATE(imin_ins,imax_ins,jmin_ins,jmax_ins)
+c      real lonmin_ins,lonmax_ins,latmin_ins
+c     s  ,latmax_ins
+c     data lonmin_ins,lonmax_ins,latmin_ins
+c    s  ,latmax_ins/
+c valeurs initiales     s   -5.,20.,41.,55./   
+c    s   100.,130.,-20.,20./
+c    s   -180.,180.,-90.,90./
+c======================================================================
+cIM cf. AM 081204 END
+
+c
+      integer itau_w   ! pas de temps ecriture = itap + itau_phy
+c
+c
+c Variables locales pour effectuer les appels en serie
+c
+      REAL t_seri(klon,klev), q_seri(klon,klev)
+      REAL ql_seri(klon,klev),qs_seri(klon,klev)
+      REAL u_seri(klon,klev), v_seri(klon,klev)
+c
+      REAL tr_seri(klon,klev,nbtr)
+      REAL d_tr(klon,klev,nbtr)
+
+      REAL zx_rh(klon,klev)
+cIM RH a 2m (la surface)
+      REAL rh2m(klon), qsat2m(klon)
+      REAL tpot(klon), tpote(klon)
+      REAL Lheat
+
+      INTEGER        length
+      PARAMETER    ( length = 100 )
+      REAL tabcntr0( length       )
+c
+      INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev)
+cIM
+      INTEGER ndex2d1(iwmax)
+c
+cIM AMIP2 BEG
+      REAL moyglo, mountor
+cIM 141004 BEG
+      REAL zustrdr(klon), zvstrdr(klon)
+      REAL zustrli(klon), zvstrli(klon)
+      REAL zustrph(klon), zvstrph(klon)
+      REAL aam, torsfc
+cIM 141004 END
+cIM 190504 BEG
+      INTEGER ij, imp1jmp1
+      PARAMETER(imp1jmp1=(iim+1)*jjmp1)
+cym A voir plus tard
+      REAL zx_tmp(imp1jmp1), airedyn(iim+1,jjmp1)
+      REAL padyn(iim+1,jjmp1,klev+1)
+      REAL dudyn(iim+1,jjmp1,klev)
+      REAL rlatdyn(iim+1,jjmp1)
+cIM 190504 END
+      LOGICAL ok_msk
+      REAL msk(klon)
+cIM 
+      REAL airetot, pi
+cym A voir plus tard
+cym      REAL zm_wo(jjmp1, klev)
+cIM AMIP2 END
+c
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+c#ifdef histmthNMC
+cym   A voir plus tard !!!!
+cym      REAL zx_tmp_NC(iim,jjmp1,nlevSTD)
+      REAL zx_tmp_fiNC(klon,nlevSTD) 
+c#endif
+      REAL*8 zx_tmp2_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev)
+      REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1)
+c
+      INTEGER nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri
+      INTEGER nid_ctesGCM
+      SAVE nid_day, nid_mth, nid_ins, nid_nmc, nid_day_seri
+      SAVE nid_ctesGCM
+c$OMP THREADPRIVATE(nid_day, nid_mth, nid_ins, nid_nmc)
+c$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM)
+c
+cIM 280405 BEG
+      INTEGER nid_bilKPins, nid_bilKPave
+      SAVE nid_bilKPins, nid_bilKPave
+c$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave)
+c
+      REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert.
+      REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert.
+      REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert.
+      REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert.
+c
+cIM 280405 END
+c
+      INTEGER nhori, nvert, nvert1, nvert3
+      REAL zsto, zsto1, zsto2
+      REAL zstophy, zstorad, zstohf, zstoday, zstomth, zout
+      REAL zcals(napisccp), zcalh(napisccp), zoutj(napisccp)
+      REAL zout_isccp(napisccp)
+      SAVE zcals, zcalh, zoutj, zout_isccp
+c$OMP THREADPRIVATE(zcals, zcalh, zoutj, zout_isccp)
+
+      real zjulian
+      save zjulian
+c$OMP THREADPRIVATE(zjulian)
+
+      character*20 modname
+      character*80 abort_message
+      logical ok_sync
+      real date0
+      integer idayref
+
+C essai writephys
+      integer fid_day, fid_mth, fid_ins
+      parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 
+      integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
+      parameter (prof2d_on = 1, prof3d_on = 2,
+     .           prof2d_av = 3, prof3d_av = 4)
+      character*30 nom_fichier
+      character*10 varname
+      character*40 vartitle
+      character*20 varunits
+C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot,
+c$OMP+              h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+c$OMP THREADPRIVATE(d_h_vcol_phy)
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/0/
+c$OMP THREADPRIVATE(ip_ebil)
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+c$OMP THREADPRIVATE(if_ebil)
+c+jld ec_conser
+      REAL d_t_ec(klon,klev)    ! tendance du a la conersion Ec -> E thermique
+      REAL ZRCPD
+c-jld ec_conser
+      REAL t2m(klon,nbsrf)  ! temperature a 2m
+      REAL q2m(klon,nbsrf)  ! humidite a 2m
+
+cIM: t2m, q2m, u10m, v10m et t2mincels, t2maxcels
+      REAL,SAVE,ALLOCATABLE :: u10m(:,:), v10m(:,:) !vents a 10m
+c$OMP THREADPRIVATE(u10m,v10m)
+      REAL zt2m(klon), zq2m(klon)             !temp., hum. 2m moyenne s/ 1 maille
+      REAL zu10m(klon), zv10m(klon)           !vents a 10m moyennes s/1 maille
+      CHARACTER*40 t2mincels, t2maxcels       !t2m min., t2m max
+      CHARACTER*40 tinst, tave, typeval
+cjq   Aerosol effects (Johannes Quaas, 27/11/2003)
+      REAL sulfate(klon, klev) ! SO4 aerosol concentration [ug/m3]
+      REAL,allocatable,save :: sulfate_pi(:,:) ! SO4 aerosol concentration [ug/m3] (pre-industrial value)
+c$OMP THREADPRIVATE(sulfate_pi)
+cym      SAVE sulfate_pi
+
+      REAL cldtaupi(klon,klev)  ! Cloud optical thickness for pre-industrial (pi) aerosols
+
+      REAL re(klon, klev)       ! Cloud droplet effective radius
+      REAL fl(klon, klev)  ! denominator of re
+
+      REAL re_top(klon), fl_top(klon) ! CDR at top of liquid water clouds
+
+      ! Aerosol optical properties
+      REAL,SAVE,ALLOCATABLE :: tau_ae(:,:,:), piz_ae(:,:,:)
+c$OMP THREADPRIVATE(tau_ae,piz_ae)
+      REAL,SAVE,ALLOCATABLE :: cg_ae(:,:,:)
+c$OMP THREADPRIVATE(cg_ae)
+
+#ifdef INCA_AER
+#ifdef CPP_COUPLE
+! Aerosol optical properties by INCA model 
+      REAL, SAVE, ALLOCATABLE  ::    tau_inca(:,:,:,:)
+      REAL, SAVE, ALLOCATABLE  ::    piz_inca(:,:,:,:)
+      REAL, SAVE, ALLOCATABLE  ::    cg_inca(:,:,:,:)
+      REAL, SAVE, ALLOCATABLE  ::    ccm(:,:,:) 
+      CHARACTER*4              ::    rfname(9) 
+
+      REAL,SAVE,ALLOCATABLE :: topswad_inca(:), solswad_inca(:) ! Aerosol direct effect.
+      REAL,SAVE,ALLOCATABLE :: topswad0_inca(:), solswad0_inca(:) ! Aerosol direct effect.
+      REAL,SAVE,ALLOCATABLE :: topswai_inca(:), solswai_inca(:) ! Aerosol indirect effect.
+      REAL,SAVE,ALLOCATABLE :: topsw_inca(:,:), solsw_inca(:,:) 
+      REAL,SAVE,ALLOCATABLE :: topsw0_inca(:,:), solsw0_inca(:,:)
+#endif
+#endif
+      REAL,SAVE,ALLOCATABLE :: topswad(:), solswad(:) ! Aerosol direct effect.
+c$OMP THREADPRIVATE(topswad,solswad)
+      ! ok_ade=T -ADE=topswad-topsw
+
+      REAL,SAVE,ALLOCATABLE :: topswai(:), solswai(:) ! Aerosol indirect effect.
+c$OMP THREADPRIVATE(topswai,solswai)
+      ! ok_aie=T ->
+      !        ok_ade=T -AIE=topswai-topswad
+      !        ok_ade=F -AIE=topswai-topsw
+
+      REAL aerindex(klon)       ! POLDER aerosol index
+     
+      ! Parameters
+      LOGICAL ok_ade, ok_aie    ! Apply aerosol (in)direct effects or not
+      REAL bl95_b0, bl95_b1   ! Parameter in Boucher and Lohmann (1995)
+cym 
+      SAVE ok_ade, ok_aie, bl95_b0, bl95_b1
+c$OMP THREADPRIVATE(ok_ade, ok_aie, bl95_b0, bl95_b1)
+
+c
+c Declaration des constantes et des fonctions thermodynamiques
+c
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+cIM 100106 BEG : pouvoir sortir les ctes de la physique
+#include "conema3.h"
+#include "fisrtilp.h"
+#include "nuage.h"
+#include "compbl.h"
+cIM 100106 END : pouvoir sortir les ctes de la physique
+c
+c======================================================================
+
+cym => necessaire pour iflag_con != 2    
+      pmfd(:,:) = 0.
+      pen_u(:,:) = 0.
+      pen_d(:,:) = 0.
+      pde_d(:,:) = 0.
+      pde_u(:,:) = 0.
+      aam=0.
+      torsfc=0.
+
+      if (first) then 
+      
+      allocate( t_ancien(klon,klev), q_ancien(klon,klev))
+      allocate( swdn0(klon,klevp1), swdn(klon,klevp1))
+      allocate( swup0(klon,klevp1), swup(klon,klevp1))
+      allocate( SWdn200clr(klon), SWdn200(klon))
+      allocate( SWup200clr(klon), SWup200(klon))
+      allocate( lwdn0(klon,klevp1), lwdn(klon,klevp1))
+      allocate( lwup0(klon,klevp1), lwup(klon,klevp1))
+      allocate( LWdn200clr(klon), LWdn200(klon))
+      allocate( LWup200clr(klon), LWup200(klon))
+      allocate( LWdnTOA(klon), LWdnTOAclr(klon))
+      allocate( radsol(klon))
+      allocate( rlat(klon))
+      allocate( rlon(klon))
+      allocate( ftsol(klon,nbsrf))
+      allocate( deltat(klon))
+      allocate( falbe(klon,nbsrf))
+      allocate( falblw(klon,nbsrf))
+      allocate( zmea(klon))
+      allocate( zstd(klon))
+      allocate( zsig(klon))
+      allocate( zgam(klon))
+      allocate( zthe(klon))
+      allocate( zpic(klon))
+      allocate( zval(klon))
+      allocate( rugoro(klon))
+      allocate( zuthe(klon),zvthe(klon))
+      allocate( alb_neig(klon))
+      allocate( ema_workcbmf(klon))   
+      allocate( ema_cbmf(klon)) 
+      allocate( ema_pcb(klon))
+      allocate( ema_pct(klon))  
+      allocate( Ma(klon,klev) )
+      allocate( qcondc(klon,klev))  
+      allocate( ema_work1(klon, klev), ema_work2(klon, klev))
+      allocate( wd(klon) )
+      allocate( pfrac_impa(klon,klev))
+      allocate( pfrac_nucl(klon,klev))
+      allocate( pfrac_1nucl(klon,klev))
+      allocate( rain_fall(klon) )
+      allocate( snow_fall(klon) )
+      allocate( total_rain(klon), nday_rain(klon))
+      allocate( pctsrf(klon,nbsrf))
+      allocate( albsol(klon))
+      allocate( albsollw(klon))
+      allocate( wo(klon,klev))
+      allocate( clwcon(klon,klev),rnebcon(klon,klev))
+      allocate( heat(klon,klev)    )
+      allocate( heat0(klon,klev)  )
+      allocate( cool(klon,klev)    )
+      allocate( cool0(klon,klev)   )
+      allocate( topsw(klon), toplw(klon), solsw(klon), sollw(klon))
+      allocate( sollwdown(klon)    )
+      allocate( sollwdownclr(klon)  ) 
+      allocate( toplwdown(klon)      )
+      allocate( toplwdownclr(klon)   )
+      allocate( topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon))
+      allocate( albpla(klon))
+      allocate( cape(klon)   )        
+      allocate( pbase(klon)   )     
+      allocate( bbase(klon)    )     
+      allocate( ibas_con(klon), itop_con(klon))
+      allocate( ratqs(klon,klev))
+      allocate( sulfate_pi(klon, klev)) 
+      allocate( paire_ter(klon))
+      allocate(tsumSTD(klon,nlevSTD,nout))
+      allocate(usumSTD(klon,nlevSTD,nout))
+      allocate(vsumSTD(klon,nlevSTD,nout))
+      allocate(wsumSTD(klon,nlevSTD,nout))
+      allocate(phisumSTD(klon,nlevSTD,nout))
+      allocate(qsumSTD(klon,nlevSTD,nout))
+      allocate(rhsumSTD(klon,nlevSTD,nout))
+      allocate(uvsumSTD(klon,nlevSTD,nout))
+      allocate(vqsumSTD(klon,nlevSTD,nout))
+      allocate(vTsumSTD(klon,nlevSTD,nout))
+      allocate(wqsumSTD(klon,nlevSTD,nout))
+      allocate( vphisumSTD(klon,nlevSTD,nout))
+      allocate( wTsumSTD(klon,nlevSTD,nout))
+      allocate( u2sumSTD(klon,nlevSTD,nout))
+      allocate( v2sumSTD(klon,nlevSTD,nout))
+      allocate( T2sumSTD(klon,nlevSTD,nout))
+      allocate( seed_old(klon,napisccp))
+      allocate( pct_ocean(klon,nbregdyn))
+      allocate( rlonPOS(klon))
+      allocate( newsst(klon))
+      allocate( zqasc(klon,klev))
+      allocate( rain_con(klon))
+      allocate( u10m(klon,nbsrf), v10m(klon,nbsrf)) 
+      allocate( topswad(klon), solswad(klon))
+      allocate( topswai(klon), solswai(klon) )
+#ifdef INCA_AER
+#ifdef CPP_COUPLE
+      allocate( topswad_inca(klon), solswad_inca(klon))
+      allocate( topswad0_inca(klon), solswad0_inca(klon))
+      allocate( topswai_inca(klon), solswai_inca(klon))
+      allocate( topsw_inca(klon,9), solsw_inca(klon,9))
+      allocate( topsw0_inca(klon,9), solsw0_inca(klon,9))
+      allocate( tau_inca(klon,klev,9,2))
+      allocate( piz_inca(klon,klev,9,2))
+      allocate( cg_inca(klon,klev,9,2))
+      allocate( ccm(klon,klev,2) )
+#endif
+#endif
+      allocate( clwcon0(klon,klev),rnebcon0(klon,klev))
+      allocate( clwcon0th(klon,klev),rnebcon0th(klon,klev))
+      allocate( tau_ae(klon,klev,2), piz_ae(klon,klev,2))
+      allocate( cg_ae(klon,klev,2))
+      allocate( snow_con(klon))
+      allocate( tnondef(klon,nlevSTD,nout)) 
+      allocate( d_u_con(klon,klev),d_v_con(klon,klev))            
+      
+      
+        paire_ter(:)=0.    
+        clwcon(:,:)=0.
+	rnebcon(:,:)=0.
+	ratqs(:,:)=0.
+	sollw(:)=0.
+	ema_work1(:,:)=0.
+	ema_work2(:,:)=0.
+cym Attention pbase pas initialise dans concvl !!!!
+        pbase(:)=0
+	
+	first=.false.
+      endif 
+
+                  
+       modname = 'physiq'
+cIM
+      IF (ip_ebil_phy.ge.1) THEN
+        DO i=1,klon
+          zero_v(i)=0.
+        END DO 
+      END IF 
+      ok_sync=.TRUE.
+      IF (nqmax .LT. 2) THEN
+         abort_message = 'eaux vapeur et liquide sont indispensables'
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      IF (debut) THEN
+         CALL suphec ! initialiser constantes et parametres phys.
+      ENDIF
+
+      print*,'CONVERGENCE PHYSIQUE THERM 1 '
+
+
+c======================================================================
+      xjour = rjourvrai
+c
+c Si c'est le debut, il faut initialiser plusieurs choses
+c          ********
+c
+       IF (debut) THEN
+C
+!rv
+         u10m(:,:)=0.
+         v10m(:,:)=0.
+         piz_ae(:,:,:)=0.
+         tau_ae(:,:,:)=0.
+         cg_ae(:,:,:)=0.
+         rain_con(:)=0.
+         snow_con(:)=0.
+         bl95_b0=0.
+         bl95_b1=0.
+         topswai(:)=0.
+         topswad(:)=0.
+         solswai(:)=0.
+         solswad(:)=0.
+#ifdef INCA_AER
+#ifdef CPP_COUPLE
+         tau_inca(:,:,:,:) = 0.
+         piz_inca(:,:,:,:) = 0.
+         cg_inca(:,:,:,:)  = 0.
+         ccm(:,:,:)        = 0.
+         topswai_inca(:)   = 0.
+         topswad_inca(:)   = 0.
+         topswad0_inca(:)  = 0.
+         topsw_inca(:,:)   = 0.
+         topsw0_inca(:,:)  = 0.
+         solswai_inca(:)   = 0.
+         solswad_inca(:)   = 0.
+         solswad0_inca(:)  = 0.
+         solsw_inca(:,:)   = 0.
+         solsw0_inca(:,:)  = 0.
+#endif
+#endif
+!rv
+!ACo
+         d_u_con(:,:) = 0.0
+         d_v_con(:,:) = 0.0
+         rnebcon0(:,:) = 0.0
+         clwcon0(:,:) = 0.0
+         rnebcon(:,:) = 0.0
+         clwcon(:,:) = 0.0
+         paire_ter(:) = 0.0
+c        nhistoW(:,:,:,:) = 0.0
+c        histoW(:,:,:,:) = 0.0
+
+cIM      
+         IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0.
+c
+c appel a la lecture du run.def physique
+c
+         call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel,
+     .                  ok_instan, ok_hf, seuil_inversion,
+     .                  fact_cldcon, facttemps,ok_newmicro,
+     .                  iflag_cldcon,iflag_ratqs,ratqsbas,ratqshaut,
+     .                  ok_ade, ok_aie, 
+     .                  bl95_b0, bl95_b1,
+     .                  iflag_thermals,nsplit_thermals)
+
+c
+c
+c Initialiser les compteurs:
+c
+         itap    = 0
+         itaprad = 0
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Un petit travail à faire ici.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         if (iflag_pbl>1) then
+             PRINT*, "Using method MELLOR&YAMADA" 
+         endif
+          ! NB! pbl_tke could/should be read and written from (re)startphy.nc
+          ALLOCATE(pbl_tke(klon,klev+1,nbsrf))  
+          pbl_tke(:,:,:) = 1.e-8 
+
+
+         CALL phyetat0 ("startphy.nc",dtime,co2_ppm_etat0,solaire_etat0,
+     .       rlat,rlon,pctsrf, ftsol,
+     .       ocean, ok_veget,
+     .       falbe, falblw, rain_fall,snow_fall,
+     .       solsw, sollw,
+     .       radsol,clesphy0,
+     .       zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0,
+     .       t_ancien, q_ancien, ancien_ok, rnebcon, ratqs,clwcon,
+     .       pbl_tke)
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+       DO i=1,klon
+         IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + 
+     $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
+     $       THEN 
+            WRITE(*,*)
+     $   'physiq apres lecture de restart: pb sous surface au point ',
+     $   i, pctsrf(i, 1 : nbsrf)
+         ENDIF 
+      ENDDO
+
+         radpas = NINT( 86400./dtime/nbapp_rad)
+c
+C on remet le calendrier a zero
+c
+         IF (raz_date .eq. 1) THEN
+           itau_phy = 0
+         ENDIF
+
+cIM cf. AM 081204 BEG
+         PRINT*,'cycle_diurne3 =',cycle_diurne
+cIM cf. AM 081204 END
+c
+         CALL printflag( tabcntr0,radpas,ok_journe,
+     ,                    ok_instan, ok_region )
+c
+         IF (ABS(dtime-pdtphys).GT.0.001) THEN
+            WRITE(lunout,*) 'Pas physique n est pas correct',dtime,
+     .                        pdtphys
+            abort_message='Pas physique n est pas correct '
+!           call abort_gcm(modname,abort_message,1)
+            dtime=pdtphys
+         ENDIF
+         IF (nlon .NE. klon) THEN
+            WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, 
+     .                      klon
+            abort_message='nlon et klon ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlev .NE. klev) THEN
+            WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev,
+     .                       klev
+            abort_message='nlev et klev ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+c
+         IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN 
+           WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
+           WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
+           abort_message='Nbre d appels au rayonnement insuffisant'
+           call abort_gcm(modname,abort_message,1)
+         ENDIF
+         WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con
+         WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=",
+     .                   ok_cvl
+c
+cKE43
+c Initialisation pour la convection de K.E. (sb):
+         IF (iflag_con.GE.3) THEN
+
+         WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3  "
+         WRITE(lunout,*)
+     .      "On va utiliser le melange convectif des traceurs qui"
+         WRITE(lunout,*)"est calcule dans convect4.3"
+         WRITE(lunout,*)" !!! penser aux logical flags de phytrac"
+
+          DO i = 1, klon
+           ema_cbmf(i) = 0.
+           ema_pcb(i)  = 0.
+           ema_pct(i)  = 0.
+           ema_workcbmf(i) = 0.
+          ENDDO
+cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG
+          DO i = 1, klon
+           ibas_con(i) = 1
+           itop_con(i) = 1
+          ENDDO
+cIM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END
+
+         ENDIF
+
+           rugoro=0.
+c34EK
+         IF (ok_orodr) THEN
+
+           rugoro=0.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH sans doute a enlever de finitivement ou, si on le garde, l'activer
+! justement quand ok_orodr = false.
+! ce rugoro est utilise par la couche limite et fait double emploi
+! avec les paramétrisations spécifiques de Francois Lott.
+!           DO i=1,klon
+!             rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+!           ENDDO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+           CALL SUGWD(klon,klev,paprs,pplay)
+           DO i=1,klon
+             zuthe(i)=0.
+             zvthe(i)=0.
+             if(zstd(i).gt.10.)then
+               zuthe(i)=(1.-zgam(i))*cos(zthe(i))
+               zvthe(i)=(1.-zgam(i))*sin(zthe(i))
+             endif
+           ENDDO
+         ENDIF
+c
+c
+         lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
+         WRITE(lunout,*)'La frequence de lecture surface est de ', 
+     .                   lmt_pas
+c
+cIM200505        ecrit_mth = NINT(86400./dtime *ecritphy)  ! tous les ecritphy jours
+c        IF (ok_mensuel) THEN
+c        WRITE(lunout,*)'La frequence de sortie mensuelle est de ', 
+c    .                   ecrit_mth
+c        ENDIF
+c        ecrit_day = NINT(86400./dtime *1.0)  ! tous les jours
+c        IF (ok_journe) THEN
+c        WRITE(lunout,*)'La frequence de sortie journaliere est de ',
+c    .                   ecrit_day
+c        ENDIF
+cIM 130904 BEG
+cIM 080205      ecrit_hf = 86400./dtime *0.25  ! toutes les 6h
+cIM 170305      
+c        ecrit_hf = 86400./dtime/12.  ! toutes les 2h
+cIM 230305      
+cIM200505        ecrit_hf = 86400./dtime *0.25  ! toutes les 6h
+c
+cIM200505        ecrit_hf2mth = ecrit_day/ecrit_hf*30
+c
+cIM200505        IF (ok_journe) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie hf est de ',
+cIM200505    .                   ecrit_hf
+cIM200505        ENDIF
+cIM 130904 END
+ccc         ecrit_ins = NINT(86400./dtime *0.5)  ! 2 fois par jour
+ccc         ecrit_ins = NINT(86400./dtime *0.25)  ! 4 fois par jour
+c        ecrit_ins = NINT(86400./dtime/48.)  ! a chaque pas de temps ==> PB. dans time_counter pour 1mois
+c        ecrit_ins = NINT(86400./dtime/12.)  ! toutes les deux heures
+cIM200505        ecrit_ins = NINT(86400./dtime/8.)  ! toutes les trois heures
+cIM200505        IF (ok_instan) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie instant. est de ', 
+cIM200505    .                   ecrit_ins
+cIM200505        ENDIF
+cIM200505        ecrit_reg = NINT(86400./dtime *0.25)  ! 4 fois par jour
+cIM200505        IF (ok_region) THEN
+cIM200505        WRITE(lunout,*)'La frequence de sortie region est de ', 
+cIM200505    .                   ecrit_reg
+cIM200505        ENDIF
+cIM 030306 BEG
+cIM ecrit_hf2mth = nombre de pas de temps de calcul de hf par mois apres lequel on ecrit
+cIM : ne pas modifier ecrit_hf2mth
+c
+         ecrit_hf2mth = 30*1/ecrit_hf 
+c ecrit_ins en secondes, chaque pas de temps de la physique
+         ecrit_ins = dtime
+cIM on passe les frequences de jours en secondes : ecrit_ins, ecrit_hf, ecrit_day, ecrit_mth, ecrit_tra, ecrit_reg
+         ecrit_hf = ecrit_hf * un_jour
+!IM
+         IF(ecrit_day.LE.1.) THEN
+          ecrit_day = ecrit_day * un_jour !en secondes
+         ENDIF
+!IM
+         ecrit_mth = ecrit_mth * un_jour
+         ecrit_reg = ecrit_reg * un_jour
+         ecrit_tra = ecrit_tra * un_jour
+         ecrit_ISCCP = ecrit_ISCCP * un_jour
+c
+         PRINT*,'physiq ecrit_ hf day mth reg tra ISCCP',ecrit_hf,
+     .   ecrit_day,ecrit_mth,ecrit_reg,ecrit_tra,ecrit_ISCCP
+cIM 030306 END
+
+      capemaxcels = 't_max(X)'
+      t2mincels = 't_min(X)'
+      t2maxcels = 't_max(X)'
+      tinst = 'inst(X)'
+      tave = 'ave(X)'
+cIM cf. AM 081204 BEG
+      write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con
+cIM cf. AM 081204 END
+c
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+
+#ifdef histhf
+#include "ini_histhf.h"
+#endif
+
+#ifdef histday
+#include "ini_histday.h"
+cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+c#include "ini_bilKP_ins.h"
+c#include "ini_bilKP_ave.h"
+#endif
+
+#ifdef histmth
+#include "ini_histmth.h"
+#endif
+
+#ifdef histins
+#include "ini_histins.h"
+#endif
+
+#ifdef histISCCP
+#include "ini_histISCCP.h"
+#endif
+
+#ifdef histmthNMC
+#include "ini_histmthNMC.h"
+#endif
+
+#include "ini_histday_seri.h"
+
+#include "ini_paramLMDZ_phy.h"
+
+#endif
+
+cXXXPB Positionner date0 pour initialisation de ORCHIDEE
+      date0 = zjulian
+C      date0 = day_ini
+      WRITE(*,*) 'physiq date0 : ',date0
+c
+c
+c
+c Prescrire l'ozone dans l'atmosphere
+c
+c
+cc         DO i = 1, klon
+cc         DO k = 1, klev
+cc            CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
+cc         ENDDO
+cc         ENDDO
+c
+#ifdef INCA
+           call VTe(VTphysiq)
+	   call VTb(VTinca)
+           iii = MOD(NINT(xjour),360)
+           calday = FLOAT(iii) + gmtime
+           WRITE(lunout,*) 'initial time ', xjour, calday
+#ifdef INCAINFO
+           WRITE(lunout,*) 'Appel CHEMINI ...'
+#endif
+           CALL chemini( 
+     $                   rg,
+     $                   ra,
+     $                   airephy,
+     $                   rlat,
+     $                   rlon,
+     $                   presnivs,
+     $                   calday,
+     $                   klon,
+     $                   nqmax,
+     $                   pdtphys,
+     $                   annee_ref,
+     $                   day_ini)
+#ifdef INCAINFO
+           WRITE(lunout,*) 'OK.'
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+c
+      ENDIF
+c
+c   ****************     Fin  de   IF ( debut  )   ***************
+c
+c
+c Mettre a zero des variables de sortie (pour securite)
+c
+      DO i = 1, klon
+         d_ps(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO iq = 1, nqmax
+      DO k = 1, klev
+      DO i = 1, klon
+         d_qx(i,k,iq) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+      da(:,:)=0.
+      mp(:,:)=0.
+      phi(:,:,:)=0.
+c
+c Ne pas affecter les valeurs entrees de u, v, h, et q
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k)  = t(i,k)
+         u_seri(i,k)  = u(i,k)
+         v_seri(i,k)  = v(i,k)
+         q_seri(i,k)  = qx(i,k,ivap)
+         ql_seri(i,k) = qx(i,k,iliq)
+         qs_seri(i,k) = 0.
+      ENDDO
+      ENDDO
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         tr_seri(i,k,iq-2) = qx(i,k,iq)
+      ENDDO
+      ENDDO
+      ENDDO
+      ELSE
+      DO k = 1, klev
+      DO i = 1, klon
+         tr_seri(i,k,1) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+        ztsol(i) = 0.
+      ENDDO
+      DO nsrf = 1, nbsrf
+        DO i = 1, klon
+          ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+        ENDDO
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after dynamic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol+d_h_vcol_phy, d_qt, 0.
+     s      , fs_bound, fq_bound )
+      END IF 
+
+c Diagnostiquer la tendance dynamique
+c
+      IF (ancien_ok) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime
+            d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime
+         ENDDO
+         ENDDO
+      ELSE
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = 0.0
+            d_q_dyn(i,k) = 0.0
+         ENDDO
+         ENDDO
+         ancien_ok = .TRUE.
+      ENDIF
+c
+c Ajouter le geopotentiel du sol:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zphi(i,k) = pphi(i,k) + pphis(i)
+      ENDDO
+      ENDDO
+c
+c Verifier les temperatures
+c
+cIM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+c
+       PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+cIM END
+c
+      CALL hgardfou(t_seri,ftsol,'debutphy')
+c
+cIM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+c
+       PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+cIM END
+c
+c Incrementer le compteur de la physique
+c
+      itap   = itap + 1
+      julien = MOD(NINT(xjour),360)
+      if (julien .eq. 0) julien = 360
+c
+c Mettre en action les conditions aux limites (albedo, sst, etc.).
+c Prescrire l'ozone et calculer l'albedo sur l'ocean.
+c
+      IF (MOD(itap-1,lmt_pas) .EQ. 0) THEN
+         WRITE(lunout,*)' PHYS cond  julien ',julien
+         CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
+      ENDIF
+c
+c Re-evaporer l'eau liquide nuageuse
+c
+      DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+c        zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+         zb = MAX(0.0,ql_seri(i,k))
+         za = - MAX(0.0,ql_seri(i,k))
+     .                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         t_seri(i,k) = t_seri(i,k) + za
+         q_seri(i,k) = q_seri(i,k) + zb
+         ql_seri(i,k) = 0.0
+         d_t_eva(i,k) = za
+         d_q_eva(i,k) = zb
+      ENDDO
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after reevap'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      END IF 
+
+c
+C calculs necessaires au calcul de l'albedo dans l'interface
+c
+      CALL orbite(FLOAT(julien),zlongi,dist)
+      IF (cycle_diurne) THEN
+        zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
+        CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
+      ELSE
+        rmu0 = -999.999
+      ENDIF
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Appel au pbl_surface : Planetary Boudary Layer et Surface
+c Cela implique tous les interactions des sous-surfaces et la partie diffusion 
+c turbulent du couche limit. 
+c 
+c Certains varibales de sorties de pbl_surface sont utiliser que pour 
+c ecriture des fihiers hist_XXXX.nc, ces sont :
+c   qsol,      zq2m,      s_pblh,  s_lcl,
+c   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+c   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+c   zxrugs,    zu10m,     zv10m,   fder,
+c   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+c   frugs,     agesno,    fsollw,  fsolsw,
+c   d_ts,      fevap,     fluxlat, t2m,
+c   wfbils,    wfbilo,    fluxt,   fluxu, fluxv,
+c
+c Certains ne sont pas utiliser du tout : 
+c   dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
+c
+      CALL pbl_surface( 
+     e     dtime,     date0,     itap,    julien,
+     e     debut,     lafin,
+     e     rlon,      rlat,      rugoro,  rmu0,     
+     e     rain_fall, snow_fall, solsw,   sollw,    
+     e     t_seri,    q_seri,    u_seri,  v_seri,   
+     e     pplay,     paprs,     pctsrf,            
+     +     ftsol,     falbe,     falblw,  u10m,   v10m,
+     s     sollwdown, cdragh,    cdragm,  yu1,    yv1,
+     s     albsol,    albsollw,  sens,    evap,  
+     s     zxtsol,    zxfluxlat, zt2m,    qsat2m, 
+     s     d_t_vdf,   d_q_vdf,   d_u_vdf, d_v_vdf,
+     s     ycoefh,    pctsrf_new,                
+     d     qsol,      zq2m,      s_pblh,  s_lcl,
+     d     s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+     d     s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+     d     zxrugs,    zu10m,     zv10m,   fder,
+     d     zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+     d     frugs,     agesno,    fsollw,  fsolsw,
+     d     d_ts,      fevap,     fluxlat, t2m,
+     d     wfbils,    wfbilo,    fluxt,   fluxu,  fluxv,
+     -     dsens,     devap,     zxsnow,
+     -     zxfluxt,   zxfluxq,   q2m,     fluxq, pbl_tke )
+c
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      pctsrf(:,:) = pctsrf_new(:,:)
+      
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_vdf(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_vdf(i,k)
+         u_seri(i,k) = u_seri(i,k) + d_u_vdf(i,k)
+         v_seri(i,k) = v_seri(i,k) + d_v_vdf(i,k)
+      ENDDO
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after surface_main'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, sens
+     e      , evap  , zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+
+c
+c Appeler la convection (au choix)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         conv_q(i,k) = d_q_dyn(i,k) 
+     .               + d_q_vdf(i,k)/dtime
+         conv_t(i,k) = d_t_dyn(i,k) 
+     .               + d_t_vdf(i,k)/dtime
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*) "avantcon=", za
+      ENDIF
+      zx_ajustq = .FALSE.
+      IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
+      IF (zx_ajustq) THEN
+         DO i = 1, klon
+            z_avant(i) = 0.0
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+            z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k))
+     .                        *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDDO
+         ENDDO
+      ENDIF
+      IF (iflag_con.EQ.1) THEN
+          stop'reactiver le call conlmd dans physiq.F'
+c     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
+c    .             d_t_con, d_q_con,
+c    .             rain_con, snow_con, ibas_con, itop_con)
+      ELSE IF (iflag_con.EQ.2) THEN
+      CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
+     e            conv_t, conv_q, -evap, omega,
+     s            d_t_con, d_q_con, rain_con, snow_con,
+     s            pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s            kcbot, kctop, kdtop, pmflxr, pmflxs)
+      WHERE (rain_con < 0.) rain_con = 0.
+      WHERE (snow_con < 0.) snow_con = 0.
+      DO i = 1, klon
+         ibas_con(i) = klev+1 - kcbot(i)
+         itop_con(i) = klev+1 - kctop(i)
+      ENDDO
+      ELSE IF (iflag_con.GE.3) THEN
+c nb of tracers for the KE convection:
+c MAF la partie traceurs est faite dans phytrac
+c on met ntra=1 pour limiter les appels mais on peut
+c supprimer les calculs / ftra.
+              ntra = 1
+c sb, oct02:
+c Schema de convection modularise et vectorise:
+c (driver commun aux versions 3 et 4)
+c
+          IF (ok_cvl) THEN ! new driver for convectL
+
+          CALL concvl (iflag_con,
+     .        dtime,paprs,pplay,t_seri,q_seri,
+     .        u_seri,v_seri,tr_seri,ntra,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,
+     .        Ma,cape,tvp,iflagctrl,
+     .        pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd,
+     .        pmflxr,pmflxs,
+     .        da,phi,mp)
+
+cIM cf. FH
+              clwcon0=qcondc
+              pmfu(:,:)=upwd(:,:)+dnwd(:,:)
+
+          ELSE ! ok_cvl
+c MAF conema3 ne contient pas les traceurs
+          CALL conema3 (dtime,
+     .        paprs,pplay,t_seri,q_seri,
+     .        u_seri,v_seri,tr_seri,ntra,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,bas,top,
+     .        Ma,cape,tvp,rflag,
+     .        pbase
+     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr
+     .        ,clwcon0)
+
+          ENDIF ! ok_cvl
+
+c
+c Correction precip
+          rain_con = rain_con * cvl_corr
+          snow_con = snow_con * cvl_corr
+c
+
+           IF (.NOT. ok_gust) THEN
+           do i = 1, klon
+            wd(i)=0.0
+           enddo
+           ENDIF
+
+c =================================================================== c
+c Calcul des proprietes des nuages convectifs
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+c   calcul des proprietes des nuages convectifs
+             clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
+             call clouds_gno
+     s       (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
+
+c =================================================================== c
+
+          DO i = 1, klon
+            ema_pcb(i)  = pbase(i)
+          ENDDO
+          DO i = 1, klon
+            ema_pct(i)  = paprs(i,itop_con(i))
+            if (itop_con(i).gt.klev-3) then
+               print*,'La convection monte trop haut '
+               print*,'itop_con(,',i,',)=',itop_con(i)
+            endif
+          ENDDO
+          DO i = 1, klon
+            ema_cbmf(i) = ema_workcbmf(i)
+          ENDDO      
+      ELSE
+          WRITE(lunout,*) "iflag_con non-prevu", iflag_con
+          CALL abort
+      ENDIF
+
+c     CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
+c    .              d_u_con, d_v_con)
+
+      DO k = 1, klev
+        DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_con(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_con(i,k)
+         u_seri(i,k) = u_seri(i,k) + d_u_con(i,k)
+         v_seri(i,k) = v_seri(i,k) + d_v_con(i,k)
+        ENDDO
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after convect'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_con, snow_con, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+C
+      IF (check) THEN
+          za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+          WRITE(lunout,*)"aprescon=", za
+          zx_t = 0.0
+          za = 0.0
+          DO i = 1, klon
+            za = za + airephy(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_con(i)+
+     .                   snow_con(i))*airephy(i)/FLOAT(klon)
+          ENDDO
+          zx_t = zx_t/za*dtime
+          WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+      IF (zx_ajustq) THEN
+          DO i = 1, klon
+            z_apres(i) = 0.0
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k))
+     .            *(paprs(i,k)-paprs(i,k+1))/RG
+            ENDDO
+          ENDDO
+          DO i = 1, klon
+            z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime)
+     .          /z_apres(i)
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              IF (z_factor(i).GT.(1.0+1.0E-08) .OR.
+     .            z_factor(i).LT.(1.0-1.0E-08)) THEN
+                  q_seri(i,k) = q_seri(i,k) * z_factor(i)
+              ENDIF
+            ENDDO
+          ENDDO
+      ENDIF
+      zx_ajustq=.FALSE.
+c
+c===================================================================
+c Convection seche (thermiques ou ajustement)
+c===================================================================
+c
+       call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri
+     s ,seuil_inversion,weak_inversion,dthmin)
+
+
+
+      d_t_ajsb(:,:)=0.
+      d_q_ajsb(:,:)=0.
+      d_t_ajs(:,:)=0.
+      d_u_ajs(:,:)=0.
+      d_v_ajs(:,:)=0.
+      d_q_ajs(:,:)=0.
+      clwcon0th(:,:)=0.
+      fm_therm(:,:)=0.
+      entr_therm(:,:)=0.
+c
+      IF(prt_level>9)WRITE(lunout,*)
+     .    'AVANT LA CONVECTION SECHE , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+      if(iflag_thermals.lt.0) then
+c  Rien
+c  ====
+         IF(prt_level>9)WRITE(lunout,*)'pas de convection'
+
+
+      else
+
+c  Thermiques
+c  ==========
+         IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+         print*,'JUSTE AVANT , iflag_thermals='
+     s   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+
+
+         if (iflag_thermals.gt.1) then
+         call calltherm(pdtphys
+     s      ,pplay,paprs,pphi,weak_inversion
+     s      ,u_seri,v_seri,t_seri,q_seri,zqsat,debut
+     s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
+     s      ,fm_therm,entr_therm,zqasc,clwcon0th,lmax_th,ratqscth,
+     s       ratqsdiff,zqsatth)
+         endif
+
+!        call calltherm(pdtphys
+!    s      ,pplay,paprs,pphi
+!    s      ,u_seri,v_seri,t_seri,q_seri
+!    s      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs
+!    s      ,fm_therm,entr_therm)
+
+c  Ajustement sec
+c  ==============
+
+! Dans le cas où on active les thermiques, on fait partir l'ajustement
+! a partir du sommet des thermiques.
+! Dans le cas contraire, on demarre au niveau 1.
+
+         if (iflag_thermals.ge.13.or.iflag_thermals.eq.0) then
+
+         if(iflag_thermals.eq.0) then
+            IF(prt_level>9)WRITE(lunout,*)'ajsec'
+            limbas(:)=1
+         else
+            limbas(:)=lmax_th(:)
+         endif
+  
+! Attention : le call ajsec_convV2 n'est maintenu que momentanneement
+! pour des test de convergence numerique.
+! Le nouveau ajsec est a priori mieux, meme pour le cas 
+! iflag_thermals = 0 (l'ancienne version peut faire des tendances
+! non nulles numeriquement pour des mailles non concernees.
+
+         if (iflag_thermals.eq.0) then
+            CALL ajsec_convV2(paprs, pplay, t_seri,q_seri
+     s      , d_t_ajsb, d_q_ajsb)
+         else
+            CALL ajsec(paprs, pplay, t_seri,q_seri,limbas
+     s      , d_t_ajsb, d_q_ajsb)
+         endif
+
+         t_seri(:,:) = t_seri(:,:) + d_t_ajsb(:,:)
+         q_seri(:,:) = q_seri(:,:) + d_q_ajsb(:,:)
+         d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
+         d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
+
+         endif
+
+      endif
+c
+c===================================================================
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after dry_adjust'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+
+
+c-------------------------------------------------------------------------
+c  Caclul des ratqs
+c-------------------------------------------------------------------------
+
+c      print*,'calcul des ratqs'
+c   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
+c   ----------------
+c   on ecrase le tableau ratqsc calcule par clouds_gno
+      if (iflag_cldcon.eq.1) then
+         do k=1,klev
+         do i=1,klon
+            if(ptconv(i,k)) then
+              ratqsc(i,k)=ratqsbas
+     s        +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+            else
+               ratqsc(i,k)=0.
+            endif
+         enddo
+         enddo
+      else if (iflag_cldcon.eq.4) then
+         ptconvth(:,:)=.false.
+         ratqsc(:,:)=0.
+         print*,'avant clouds_gno thermique'
+         call clouds_gno
+     s   (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th)
+         print*,' CLOUDS_GNO OK'
+      endif
+
+c   ratqs stables
+c   -------------
+
+      if (iflag_ratqs.eq.0) then
+
+! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele.
+         do k=1,klev
+            do i=1, klon
+               ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s         min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) 
+            enddo 
+         enddo
+
+! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de 
+! 300 hPa (ratqshaut), varie lineariement en fonction de la pression
+! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1
+! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2
+! Il s'agit de differents tests dans la phase de reglage du modele
+! avec thermiques.
+
+      else if (iflag_ratqs.eq.1) then
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas
+               else if ((pplay(i,k).ge.30000.).and.
+     s            (pplay(i,k).lt.60000.)) then
+                  ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s            (60000.-pplay(i,k))/(60000.-30000.)
+               else
+                  ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+
+      else
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas
+     s            *(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.)
+               else if ((pplay(i,k).ge.30000.).and.
+     s             (pplay(i,k).lt.60000.)) then
+                    ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s              (60000.-pplay(i,k))/(60000.-30000.)
+               else
+                    ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+      endif
+
+
+
+
+c  ratqs final
+c  -----------
+
+      if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2
+     s    .or.iflag_cldcon.eq.4) then
+
+! On ajoute une constante au ratqsc*2 pour tenir compte de 
+! fluctuations turbulentes de petite echelle
+
+         do k=1,klev
+            do i=1,klon
+               if ((fm_therm(i,k).gt.1.e-10)) then
+                  ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2)
+               endif
+            enddo
+         enddo
+
+!   les ratqs sont une conbinaison de ratqss et ratqsc
+!   1800s, en dur pour le moment, est le temps de
+!   relaxation des ratqs
+
+         facteur=exp(-pdtphys/1800.)
+
+         print*,'WARNING ratqs a revoir '
+         ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur
+         ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2)
+
+      else
+!   on ne prend que le ratqs stable pour fisrtilp
+         ratqs(:,:)=ratqss(:,:)
+      endif
+
+
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c-------------------------------------------------------------------------
+      CALL fisrtilp(dtime,paprs,pplay,
+     .           t_seri, q_seri,ptconv,ratqs,
+     .           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq,
+     .           rain_lsc, snow_lsc,
+     .           pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     .           frac_impa, frac_nucl,
+     .           prfl, psfl, rhcl)
+
+      WHERE (rain_lsc < 0) rain_lsc = 0.
+      WHERE (snow_lsc < 0) snow_lsc = 0.
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_lsc(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_lsc(i,k)
+         ql_seri(i,k) = ql_seri(i,k) + d_ql_lsc(i,k)
+         cldfra(i,k) = rneb(i,k)
+         IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*)"apresilp=", za
+         zx_t = 0.0
+         za = 0.0
+         DO i = 1, klon
+            za = za + airephy(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_lsc(i)
+     .                  + snow_lsc(i))*airephy(i)/FLOAT(klon)
+        ENDDO
+         zx_t = zx_t/za*dtime
+         WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after fisrt'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_lsc, snow_lsc, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+c
+c-------------------------------------------------------------------
+c  PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
+c-------------------------------------------------------------------
+
+c 1. NUAGES CONVECTIFS
+c
+cIM cf FH
+c     IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke
+      IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke
+       snow_tiedtke=0.
+c     print*,'avant calcul de la pseudo precip '
+c     print*,'iflag_cldcon',iflag_cldcon
+       if (iflag_cldcon.eq.-1) then
+          rain_tiedtke=rain_con
+       else
+c       print*,'calcul de la pseudo precip '
+          rain_tiedtke=0.
+c         print*,'calcul de la pseudo precip 0'
+          do k=1,klev
+          do i=1,klon
+             if (d_q_con(i,k).lt.0.) then
+                rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys
+     s         *(paprs(i,k)-paprs(i,k+1))/rg
+             endif
+          enddo
+          enddo
+       endif
+c
+c     call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ')
+c
+
+c Nuages diagnostiques pour Tiedtke
+      CALL diagcld1(paprs,pplay,
+cIM cf FH  .             rain_con,snow_con,ibas_con,itop_con,
+     .             rain_tiedtke,snow_tiedtke,ibas_con,itop_con,
+     .             diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+
+      ELSE IF (iflag_cldcon.ge.3) THEN
+c  On prend pour les nuages convectifs le max du calcul de la
+c  convection et du calcul du pas de temps precedent diminue d'un facteur
+c  facttemps
+      facteur = pdtphys *facttemps
+      do k=1,klev
+         do i=1,klon
+            rnebcon(i,k)=rnebcon(i,k)*facteur
+            if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k))
+     s      then
+                rnebcon(i,k)=rnebcon0(i,k)
+                clwcon(i,k)=clwcon0(i,k)
+            endif
+         enddo
+      enddo
+
+c
+cjq - introduce the aerosol direct and first indirect radiative forcings
+cjq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
+      IF (ok_ade.OR.ok_aie) THEN
+#if defined(CPP_COUPLE) && !defined(INCA_AER)
+         ! Get sulfate aerosol distribution
+         CALL readsulfate(rjourvrai, debut, sulfate)
+         CALL readsulfate_preind(rjourvrai, debut, sulfate_pi)
+
+         ! Calculate aerosol optical properties (Olivier Boucher)
+         CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl,
+     .        tau_ae, piz_ae, cg_ae, aerindex)
+#endif
+#if !defined(CPP_COUPLE)
+         ! Get sulfate aerosol distribution
+         CALL readsulfate(rjourvrai, debut, sulfate)
+         CALL readsulfate_preind(rjourvrai, debut, sulfate_pi)
+
+         ! Calculate aerosol optical properties (Olivier Boucher)
+         CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl,
+     .        tau_ae, piz_ae, cg_ae, aerindex)
+#endif
+cym
+      ELSE
+        tau_ae(:,:,:)=0.0
+	piz_ae(:,:,:)=0.0
+	cg_ae(:,:,:)=0.0
+cym     
+      ENDIF
+
+c
+cIM calcul nuages par le simulateur ISCCP
+c
+#ifdef histISCCP
+      IF (ok_isccp) THEN
+cIM appel simulateur toutes les  NINT(freq_ISCCP/dtime) heures
+       IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN
+#include "calcul_simulISCCP.h"
+       ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime))
+      ENDIF !ok_isccp
+#endif
+
+c   On prend la somme des fractions nuageuses et des contenus en eau
+      cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+      cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
+
+      ENDIF
+
+c
+c 2. NUAGES STARTIFORMES
+c
+      IF (ok_stratus) THEN
+      CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Precipitation totale
+c
+      DO i = 1, klon
+         rain_fall(i) = rain_con(i) + rain_lsc(i)
+         snow_fall(i) = snow_con(i) + snow_lsc(i)
+      ENDDO
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit="after diagcld"
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c Calculer l'humidite relative pour diagnostique
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zx_rh(i,k) = q_seri(i,k)/zx_qs
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+cIM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 
+c   equivalente a 2m (tpote) pour diagnostique
+c
+      DO i = 1, klon
+       tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA
+       IF (thermcep) THEN
+        IF(zt2m(i).LT.RTT) then
+	 Lheat=RLSTT
+	ELSE
+	 Lheat=RLVTT
+        ENDIF
+       ELSE
+        IF (zt2m(i).LT.RTT) THEN
+         Lheat=RLSTT
+        ELSE
+	 Lheat=RLVTT
+        ENDIF
+       ENDIF
+       tpote(i) = tpot(i)*     
+     . EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i)))
+      ENDDO
+
+
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+           calday = FLOAT(julien) + gmtime
+
+#ifdef INCA_AER
+      call AEROSOL_METEO_CALC(calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs
+     &   ,prfl,psfl,pctsrf,airephy,xjour,rlat,rlon,u10m,v10m)
+#endif
+
+#ifdef INCAINFO
+           WRITE(lunout,*)'Appel CHEMHOOK_BEGIN ...'
+#endif
+
+           zxsnow_dummy(:) = 0.0
+
+           CALL chemhook_begin (calday,
+#if defined(INCA) && !defined(INCA_CH4) && !defined(INCA_NMHC) && !defined(INCA_AER)
+     $                          julien,
+     $                          gmtime,
+#endif
+     $                          pctsrf(1,1),
+     $                          rlat,
+     $                          rlon,
+     $                          airephy,
+     $                          paprs,
+     $                          pplay,
+     $                          ycoefh,
+     $                          pphi,
+     $                          t_seri,
+     $                          u,
+     $                          v,
+     $                          wo,
+     $                          q_seri,
+     $                          zxtsol,
+     $                          zxsnow_dummy,
+     $                          solsw,
+     $                          albsol,
+     $                          rain_fall,
+     $                          snow_fall,
+     $                          itop_con,
+     $                          ibas_con,
+     $                          cldfra,
+     $                          iim,
+     $                          jjm,
+#ifdef INCA_AER
+     $                          tr_seri,
+     $                          ftsol,
+     $                          paprs,
+     $                          cdragh,
+     $                          cdragm,
+     $                          pctsrf,
+     $				pdtphys,
+     $				itap)
+#else
+     $                          tr_seri)     
+#endif        
+
+
+#ifdef INCAINFO
+           WRITE(lunout,*)'OK.'
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+c     
+c Calculer les parametres optiques des nuages et quelques
+c parametres pour diagnostiques:
+c
+      if (ok_newmicro) then
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq,
+     .            flwp, fiwp, flwc, fiwc,
+     e            ok_aie,
+#if defined(CPP_COUPLE) && defined(INCA_AER)  
+     e            ccm(:,:,1), ccm(:,:,2),
+#else
+     e            sulfate, sulfate_pi,
+#endif
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+      else
+      CALL nuage (paprs, pplay,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq,
+     e            ok_aie,
+     e            sulfate, sulfate_pi,
+     e            bl95_b0, bl95_b1,
+     s            cldtaupi, re, fl)
+      
+      endif
+c
+c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
+c
+      IF (MOD(itaprad,radpas).EQ.0) THEN
+
+      DO i = 1, klon
+         albsol(i) = falbe(i,is_oce) * pctsrf(i,is_oce)
+     .             + falbe(i,is_lic) * pctsrf(i,is_lic)
+     .             + falbe(i,is_ter) * pctsrf(i,is_ter)
+     .             + falbe(i,is_sic) * pctsrf(i,is_sic)
+         albsollw(i) = falblw(i,is_oce) * pctsrf(i,is_oce)
+     .               + falblw(i,is_lic) * pctsrf(i,is_lic)
+     .               + falblw(i,is_ter) * pctsrf(i,is_ter)
+     .               + falblw(i,is_sic) * pctsrf(i,is_sic)
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+
+#if defined(CPP_COUPLE) && defined(INCA_AER)
+      CALL radlwsw_inca ! nouveau rayonnement (compatible Arpege-IFS)
+     e            (kdlon,kflev,dist, rmu0, fract, 
+     e             paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
+     e             wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             lwdn0, lwdn, lwup0, lwup, 
+     s             swdn0, swdn, swup0, swup,
+     e             ok_ade, ok_aie, ! new for aerosol radiative effects
+     e             tau_inca, piz_inca, cg_inca, ! ="=
+     s             topswad_inca, solswad_inca, ! ="=
+     s             topswad0_inca, solswad0_inca, ! ="=
+     s             topsw_inca, topsw0_inca,
+     s             solsw_inca, solsw0_inca,
+     e             cldtaupi, ! ="=
+     s             topswai_inca, solswai_inca) ! ="=
+#else
+      CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS)
+     e            (dist, rmu0, fract, 
+     e             paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
+     e             wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             lwdn0, lwdn, lwup0, lwup, 
+     s             swdn0, swdn, swup0, swup,
+     e             ok_ade, ok_aie, ! new for aerosol radiative effects
+     e             tau_ae, piz_ae, cg_ae, ! ="=
+     s             topswad, solswad, ! ="=
+     e             cldtaupi, ! ="=
+     s             topswai, solswai) ! ="=
+#endif
+      itaprad = 0
+      ENDIF
+      itaprad = itaprad + 1
+c
+c Ajouter la tendance des rayonnements (tous les pas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k)
+     .               + (heat(i,k)-cool(i,k)) * dtime/86400.
+      ENDDO
+      ENDDO
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+ 
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after rad'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , topsw, toplw, solsw, sollw, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+c
+c
+c Calculer l'hydrologie de la surface
+c
+c      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
+c     .            agesno, ftsol,fqsurf,fsnow, ruis)
+c
+
+c
+c Calculer le bilan du sol et la derive de temperature (couplage)
+c
+      DO i = 1, klon
+c         bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
+c a la demande de JLD
+         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
+      ENDDO
+c
+cmoddeblott(jan95)
+c Appeler le programme de parametrisation de l'orographie
+c a l'echelle sous-maille:
+c
+      IF (ok_orodr) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+c        IF ((zstd(i).gt.10.0)) THEN
+        IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL drag_noro(klon,klev,dtime,paprs,pplay,
+     e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,idx,itest,
+     e                   t_seri, u_seri, v_seri,
+cIM 141004    s                   zulow, zvlow, zustr, zvstr,
+     s                   zulow, zvlow, zustrdr, zvstrdr,
+     s                   d_t_oro, d_u_oro, d_v_oro)
+c
+c  ajout des tendances
+        DO k = 1, klev
+        DO i = 1, klon
+           t_seri(i,k) = t_seri(i,k) + d_t_oro(i,k)
+           u_seri(i,k) = u_seri(i,k) + d_u_oro(i,k)
+           v_seri(i,k) = v_seri(i,k) + d_v_oro(i,k)
+        ENDDO
+        ENDDO
+c
+      ENDIF ! fin de test sur ok_orodr
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+      IF (ok_orolf) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+        IF ((zpic(i)-zmea(i)).GT.100.) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL lift_noro(klon,klev,dtime,paprs,pplay,
+     e                   rlat,zmea,zstd,zpic,
+     e                   itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustrli, zvstrli,
+     s                   d_t_lif, d_u_lif, d_v_lif)
+c
+c  ajout des tendances
+        DO k = 1, klev
+        DO i = 1, klon
+           t_seri(i,k) = t_seri(i,k) + d_t_lif(i,k)
+           u_seri(i,k) = u_seri(i,k) + d_u_lif(i,k)
+           v_seri(i,k) = v_seri(i,k) + d_v_lif(i,k)
+        ENDDO
+        ENDDO
+c
+      ENDIF ! fin de test sur ok_orolf
+c
+cIM cf. FLott BEG
+C STRESS NECESSAIRES: TOUTE LA PHYSIQUE
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO i = 1, klon
+        zustrph(i)=0.
+        zvstrph(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+       zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime*
+     c            (paprs(i,k)-paprs(i,k+1))/rg
+       zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime*
+     c            (paprs(i,k)-paprs(i,k+1))/rg
+      ENDDO
+      ENDDO
+c
+cIM calcul composantes axiales du moment angulaire et couple des montagnes
+c
+      IF (is_sequential) THEN
+      
+        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+     C                 ra,rg,romega,
+     C                 rlat,rlon,pphis,
+     C                 zustrdr,zustrli,zustrph,
+     C                 zvstrdr,zvstrli,zvstrph,
+     C                 paprs,u,v,
+     C                 aam, torsfc)
+       ENDIF
+cIM cf. FLott END
+cIM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after orography'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c
+cAA
+cAA Installation de l'interface online-offline pour traceurs
+cAA
+c====================================================================
+c   Calcul  des tendances traceurs
+c====================================================================
+C
+      call phytrac (     rnpb,
+     I                   itap, 
+     I                   julien, 
+     I                   gmtime,
+     I                   debut,
+     I                   lafin,
+     I                   nqmax-2,
+     I                   nlon,
+     I                   nlev,
+     I                   dtime,
+     I                   u,
+     I                   v,
+     I                   t,
+     I                   paprs,
+     I                   pplay,
+     I                   pmfu, 
+     I                   pmfd, 
+     I                   pen_u, 
+     I                   pde_u, 
+     I                   pen_d, 
+     I                   pde_d,
+     I                   ycoefh,
+     I                   fm_therm,
+     I                   entr_therm,
+     I                   yu1,
+     I                   yv1,
+     I                   ftsol,
+     I                   pctsrf,
+     I                   rlat,
+     I                   frac_impa, 
+     I                   frac_nucl,
+     I                   rlon,
+     I                   presnivs,
+     I                   pphis,
+     I                   pphi,
+     I                   albsol,
+     I                   qx(1,1,1), 
+     I                   rhcl,
+     I                   cldfra, 
+     I                   rneb, 
+     I                   diafra, 
+     I                   cldliq, 
+     I                   itop_con,
+     I                   ibas_con,
+     I                   pmflxr,
+     I                   pmflxs,
+     I                   prfl,
+     I                   psfl,
+     I                   da,
+     I                   phi,
+     I                   mp,
+     I                   upwd,
+     I                   dnwd,
+#ifdef INCA
+     I                   flxmass_w,
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+     I                   tau_inca, 
+     I                   piz_inca, 
+     I                   cg_inca,
+     I                   ccm,
+     I                   rfname,
+#endif
+#endif
+     O                   tr_seri)
+
+      IF (offline) THEN
+
+         print*,'Attention on met a 0 les thermiques pour phystoke'
+	 call phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   fm_therm,entr_therm,
+     I                   ycoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa, frac_nucl,
+     I                   pphis,airephy,dtime,itap)
+
+
+      ENDIF
+
+c
+c Calculer le transport de l'eau et de l'energie (diagnostique)
+c
+      CALL transp (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve, vq, ue, uq)
+c
+cIM global posePB BEG
+      IF(1.EQ.0) THEN
+c
+      CALL transp_lay (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve_lay, vq_lay, ue_lay, uq_lay)
+c
+      ENDIF !(1.EQ.0) THEN
+cIM global posePB END
+c Accumuler les variables a stocker dans les fichiers histoire:
+c
+c+jld ec_conser
+      DO k = 1, klev
+      DO i = 1, klon
+        ZRCPD = RCPD*(1.0+RVTMP2*q_seri(i,k))
+        d_t_ec(i,k)=0.5/ZRCPD
+     $      *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2)
+        t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k)
+        d_t_ec(i,k) = d_t_ec(i,k)/dtime
+       END DO 
+      END DO 
+c-jld ec_conser
+cIM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after physic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy
+     e      , topsw, toplw, solsw, sollw, sens
+     e      , evap, rain_fall, snow_fall, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      d_h_vcol_phy=d_h_vcol
+C
+      END IF 
+C
+c=======================================================================
+c   SORTIES
+c=======================================================================
+
+cIM Interpolation sur les niveaux de pression du NMC
+c   -------------------------------------------------
+c
+#include "calcul_STDlev.h"
+c
+c slp sea level pressure
+      slp(:) = paprs(:,1)*exp(pphis(:)/(RD*t_seri(:,1)))
+c
+ccc prw = eau precipitable
+      DO i = 1, klon
+       prw(i) = 0.
+       DO k = 1, klev
+        prw(i) = prw(i) +
+     .           q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+       ENDDO
+      ENDDO
+c
+cIM initialisation + calculs divers diag AMIP2
+c
+#include "calcul_divers.h"
+c
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+#ifdef INCAINFO
+           WRITE(lunout,*)'Appel CHEMHOOK_END ...'
+#endif
+           CALL chemhook_end (calday,
+     $                        dtime,
+     $                        pplay,
+     $                        t_seri,
+     $                        tr_seri,
+     $                        nbtr,
+     $                        paprs,
+     $                        q_seri,
+     $                        annee_ref,
+     $                        day_ini,
+     $                        airephy,
+#ifdef INCA_AER
+     $                        xjour,
+     $                        pphi,
+     $                        pphis,
+     $                        zx_rh)
+#else
+     $                        xjour)
+#endif
+#ifdef INCAINFO
+           WRITE(lunout,*)'OK.'
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#endif
+
+c=============================================================
+c
+c Convertir les incrementations en tendances
+c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
+         d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
+         d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
+         d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
+         d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
+      ENDDO
+      ENDDO
+c
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDIF
+c
+cIM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+cIM global posePB#include "write_bilKP_ins.h"
+cIM global posePB#include "write_bilKP_ave.h"
+c
+c Sauvegarder les valeurs de t et q a la fin de la physique:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_ancien(i,k) = t_seri(i,k)
+         q_ancien(i,k) = q_seri(i,k)
+      ENDDO
+      ENDDO
+c
+c 22.03.04 BEG
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+#ifdef CPP_IOIPSL
+ 
+c Recupere des varibles calcule dans differents modules
+c pour ecriture dans histxxx.nc 
+
+      ! Get some variables from module mod_fonte_neige
+      CALL fonte_neige_get_vars(pctsrf, 
+     .     zxfqcalving, zxfqfonte, zxffonte)
+
+      IF (ocean == 'slab') THEN
+         ! Get some variables from module oceanslab
+         CALL ocean_slab_get_vars(tslab, seaice, fluxo, fluxg)
+      ELSEIF (ocean == 'couple') THEN
+         ! Get some variables from module oceancpl
+         CALL ocean_cpl_get_vars(fluxo, fluxg)
+      ELSE 
+         ! Get some variables from module oceanforced
+         CALL ocean_forced_get_vars(fluxo, fluxg)
+      ENDIF
+
+#ifdef histhf
+#include "write_histhf.h"
+#endif
+
+#ifdef histday
+#include "write_histday.h"
+#endif
+
+#ifdef histmth
+#include "write_histmth.h"
+#endif
+
+#ifdef histins
+#include "write_histins.h"
+#endif
+
+#ifdef histISCCP
+#include "write_histISCCP.h"
+#endif
+
+#ifdef histmthNMC
+#include "write_histmthNMC.h"
+#endif
+
+#include "write_histday_seri.h"
+
+#include "write_paramLMDZ_phy.h"
+
+#endif
+
+c 22.03.04 END
+c
+c====================================================================
+c Si c'est la fin, il faut conserver l'etat de redemarrage
+c====================================================================
+c
+      
+
+      IF (lafin) THEN
+         itau_phy = itau_phy + itap
+         CALL phyredem ("restartphy.nc",dtime,radpas,ocean,
+     .      rlat, rlon, pctsrf, ftsol,
+     .      falbe,falblw, rain_fall, 
+     .      snow_fall,
+     .      solsw, sollw,
+     .      radsol,
+     .      zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,
+     .      t_ancien, q_ancien, rnebcon, ratqs, clwcon,
+     .      pbl_tke)
+      ENDIF
+      
+
+      RETURN
+      END
+      FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
+      IMPLICIT none
+c
+c Calculer et imprimer l'eau totale. A utiliser pour verifier
+c la conservation de l'eau
+c
+#include "YOMCST.h"
+      INTEGER klon,klev
+      REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
+      REAL aire(klon)
+      REAL qtotal, zx, qcheck
+      INTEGER i, k
+c
+      zx = 0.0
+      DO i = 1, klon
+         zx = zx + aire(i)
+      ENDDO
+      qtotal = 0.0
+      DO k = 1, klev
+      DO i = 1, klon
+         qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i)
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+      ENDDO
+      ENDDO
+c
+      qcheck = qtotal/zx
+c
+      RETURN
+      END
+      SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+      IMPLICIT none
+c
+c Tranformer une variable de la grille physique a
+c la grille d'ecriture
+c
+      INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
+c
+      INTEGER i, n, ig
+c
+      jjm = jjmp1 - 1
+      DO n = 1, nfield
+         DO i=1,iim
+            ecrit(i,n) = fi(1,n)
+            ecrit(i+jjm*iim,n) = fi(nlon,n)
+         ENDDO
+         DO ig = 1, nlon - 2
+           ecrit(iim+ig,n) = fi(1+ig,n)
+         ENDDO
+      ENDDO
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/phystokenc.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/phystokenc.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/phystokenc.F	(revision 984)
@@ -0,0 +1,430 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   pfm_therm,pentr_therm,
+     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa,frac_nucl,
+     I                   pphis,paire,dtime,itap)
+      USE ioipsl
+      USE dimphy
+      USE iophy
+      IMPLICIT none
+
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+
+c======================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "tracstoke.h"
+#include "indicesol.h"
+#include "control.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon ! nombre de points horizontaux
+      integer nlev ! nombre de couches verticales
+      real pdtphys ! pas d'integration pour la physique (seconde)
+c
+      integer physid, itap
+      save physid
+c$OMP THREADPRIVATE(physid)
+      integer ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
+
+c   convection:
+c   -----------
+c
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+      real pt(klon,klev)
+      REAL,allocatable,save :: t(:,:)
+c$OMP THREADPRIVATE(t)
+c
+      REAL rlon(klon), rlat(klon), dtime
+      REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
+
+c   Couche limite:
+c   --------------
+c
+      REAL pcoefh(klon,klev)    ! coeff melange CL
+      REAL yv1(klon)
+      REAL yu1(klon),pphis(klon),paire(klon)
+
+c   Les Thermiques : (Abderr 25 11 02)
+c   ---------------
+      REAL pfm_therm(klon,klev+1)
+      real fm_therm1(klon,klev)
+      REAL pentr_therm(klon,klev)
+    
+      REAL,allocatable,save :: entr_therm(:,:)
+      REAL,allocatable,save :: fm_therm(:,:)
+c$OMP THREADPRIVATE(entr_therm)
+c$OMP THREADPRIVATE(fm_therm)
+c
+c   Lessivage:
+c   ----------
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+c
+c Arguments necessaires pour les sources et puits de traceur
+C
+      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c======================================================================
+c
+      INTEGER i, k
+c
+      REAL,allocatable,save :: mfu(:,:)  ! flux de masse dans le panache montant
+      REAL,allocatable,save :: mfd(:,:)  ! flux de masse dans le panache descendant
+      REAL,allocatable,save :: en_u(:,:) ! flux entraine dans le panache montant
+      REAL,allocatable,save :: de_u(:,:) ! flux detraine dans le panache montant
+      REAL,allocatable,save :: en_d(:,:) ! flux entraine dans le panache descendant
+      REAL,allocatable,save :: de_d(:,:) ! flux detraine dans le panache descendant
+      REAL,allocatable,save :: coefh(:,:) ! flux detraine dans le panache descendant
+
+      REAL,allocatable,save :: pyu1(:)
+      REAL,allocatable,save :: pyv1(:)
+      REAL,allocatable,save :: pftsol(:,:)
+      REAL,allocatable,save :: ppsrf(:,:)
+c$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
+c$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
+      real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
+      real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
+
+      REAL dtcum
+
+      integer iadvtr,irec
+      real zmin,zmax
+      logical ok_sync
+ 
+      save dtcum
+      save iadvtr,irec
+c$OMP THREADPRIVATE(dtcum,iadvtr,irec)
+      data iadvtr,irec/0,1/
+      logical,save :: first=.true.
+c$OMP THREADPRIVATE(first)
+c
+c   Couche limite:
+c======================================================================
+
+      ok_sync = .true.
+	print*,'Dans phystokenc.F'
+      print*,'iadvtr= ',iadvtr
+      print*,'istphy= ',istphy
+      print*,'istdyn= ',istdyn
+
+      if (first) then
+      
+        allocate( t(klon,klev))
+        allocate( mfu(klon,klev))  
+        allocate( mfd(klon,klev))  
+        allocate( en_u(klon,klev)) 
+        allocate( de_u(klon,klev)) 
+        allocate( en_d(klon,klev)) 
+        allocate( de_d(klon,klev)) 
+        allocate( coefh(klon,klev)) 
+        allocate( entr_therm(klon,klev))
+        allocate( fm_therm(klon,klev))
+        allocate( pyu1(klon))
+        allocate( pyv1(klon))
+        allocate( pftsol(klon,nbsrf))
+        allocate( ppsrf(klon,nbsrf))
+  
+        first=.false.
+      endif
+      
+      IF (iadvtr.eq.0) THEN
+	
+	CALL initphysto('phystoke',
+     . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)
+  	
+	write(*,*) 'apres initphysto ds phystokenc' 
+
+	
+      ENDIF
+c
+      ndex2d = 0
+      ndex3d = 0
+      i=itap 
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(physid,"phis",i,pphis)
+c
+      i=itap
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+      CALL histwrite_phy(physid,"aire",i,paire)
+
+      iadvtr=iadvtr+1
+c
+      if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
+	print*,'reinitialisation des champs cumules 
+     s          a iadvtr=',iadvtr
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+                t(i,k)=0.
+		fm_therm(i,k)=0.
+               entr_therm(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+                t(i,k)=t(i,k)+pt(i,k)*pdtphys
+       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+
+      IF(mod(iadvtr,istphy).eq.0) THEN 
+c
+c   normalisation par le temps cumule
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=mfu(i,k)/dtcum
+               mfd(i,k)=mfd(i,k)/dtcum
+               en_u(i,k)=en_u(i,k)/dtcum
+               de_u(i,k)=de_u(i,k)/dtcum
+               en_d(i,k)=en_d(i,k)/dtcum
+               de_d(i,k)=de_d(i,k)/dtcum
+               coefh(i,k)=coefh(i,k)/dtcum
+c Unitel a enlever
+	      t(i,k)=t(i,k)/dtcum	
+               fm_therm(i,k)=fm_therm(i,k)/dtcum
+	       entr_therm(i,k)=entr_therm(i,k)/dtcum
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)/dtcum
+            pyu1(i)=pyu1(i)/dtcum
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)/dtcum
+               pftsol1(i) = pftsol(i,1)
+               pftsol2(i) = pftsol(i,2)
+               pftsol3(i) = pftsol(i,3)
+               pftsol4(i) = pftsol(i,4)
+
+               ppsrf(i,k)=ppsrf(i,k)/dtcum
+               ppsrf1(i) = ppsrf(i,1)
+               ppsrf2(i) = ppsrf(i,2)
+               ppsrf3(i) = ppsrf(i,3)
+               ppsrf4(i) = ppsrf(i,4)
+
+            enddo
+         enddo
+c
+c   ecriture des champs
+c
+         irec=irec+1
+
+ccccc
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
+         CALL histwrite_phy(physid,"t",itap,t)
+
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
+      CALL histwrite_phy(physid,"mfu",itap,mfu)
+cym	CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
+      CALL histwrite_phy(physid,"mfd",itap,mfd)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_u",itap,en_u)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
+      CALL histwrite_phy(physid,"de_u",itap,de_u)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_d",itap,en_d)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)       
+      CALL histwrite_phy(physid,"de_d",itap,de_d)
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)         
+      CALL histwrite_phy(physid,"coefh",itap,coefh)	
+
+c ajou...
+	do k=1,klev
+           do i=1,klon
+	 fm_therm1(i,k)=fm_therm(i,k)	
+	   enddo
+	enddo
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, fm_therm1, zx_tmp_3d)
+      CALL histwrite_phy(physid,"fm_th",itap,fm_therm1)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, entr_therm, zx_tmp_3d)
+      CALL histwrite_phy(physid,"en_th",itap,entr_therm)
+cccc
+cym       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
+        CALL histwrite_phy(physid,"frac_impa",itap,frac_impa)
+
+cym        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
+        CALL histwrite_phy(physid,"frac_nucl",itap,frac_nucl)
+ 
+cym        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
+      CALL histwrite_phy(physid,"pyu1",itap,pyu1)
+	
+cym	CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
+      CALL histwrite_phy(physid,"pyv1",itap,pyv1)
+	
+cym	CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol1",itap,pftsol1)
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol2",itap,pftsol2)
+cym          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol3",itap,pftsol3)
+cym         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
+      CALL histwrite_phy(physid,"ftsol4",itap,pftsol4)
+
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf1",itap,ppsrf1)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf2",itap,ppsrf2)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf3",itap,ppsrf3)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
+      CALL histwrite_phy(physid,"psrf4",itap,ppsrf4)
+
+c$OMP MASTER
+      if (ok_sync) call histsync(physid)
+c$OMP END MASTER
+c     if (ok_sync) call histsync
+	
+c
+cAA Test sur la valeur des coefficients de lessivage 
+c
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_nucl(i,k))
+                  zmin=min(zmin,frac_nucl(i,k))
+            enddo
+         enddo
+         Print*,'------ coefs de lessivage (min et max) --------'
+         Print*,'facteur de nucleation ',zmin,zmax
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_impa(i,k))
+                  zmin=min(zmin,frac_impa(i,k))
+            enddo
+         enddo
+         Print*,'facteur d impaction ',zmin,zmax
+
+      ENDIF 
+
+c   reinitialisation des champs cumules
+	go to 768
+      if (mod(iadvtr,istphy).eq.1) then
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+	       t(i,k)=0.
+               fm_therm(i,k)=0.
+	       entr_therm(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+		t(i,k)=t(i,k)+pt(i,k)*pdtphys
+       fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+       entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+768   continue
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/phytrac.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/phytrac.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/phytrac.F	(revision 984)
@@ -0,0 +1,957 @@
+!
+! $Header$
+!
+c
+c
+      SUBROUTINE phytrac (rnpb,
+     I                    nstep,
+     I                    julien,
+     I                    gmtime,
+     I                    debutphy,
+     I                    lafin,
+     I                    nqmax,
+     I                    nlon,
+     I                    nlev,
+     I                    pdtphys,
+     I                    u,
+     I                    v,
+     I                    t_seri,
+     I                    paprs,
+     I                    pplay,
+     I                    pmfu,
+     I                    pmfd,
+     I                    pen_u,
+     I                    pde_u,
+     I                    pen_d,
+     I                    pde_d,
+     I                    coefh,
+     I                    fm_therm,
+     I                    entr_therm,
+     I                    yu1,
+     I                    yv1,
+     I                    ftsol,
+     I                    pctsrf,
+     I                    xlat,
+     I                    frac_impa,
+     I                    frac_nucl,
+     I                    xlon,
+     I                    presnivs,
+     I                    pphis,
+     I                    pphi,
+     I                    albsol,
+     I                    sh,
+     I                    rh,
+     I                    cldfra,
+     I                    rneb,
+     I                    diafra,
+     I                    cldliq,
+     I                    itop_con,
+     I                    ibas_con,
+     I                    pmflxr,
+     I                    pmflxs,
+     I                    prfl,
+     I                    psfl,
+     I                    da,
+     I                    phi,
+     I                    mp,
+     I                    upwd,
+     I                    dnwd,
+#ifdef INCA
+     I                    flxmass_w,
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+     I                   tau_inca, 
+     I                   piz_inca, 
+     I                   cg_inca,
+     I                   ccm,
+     I                   rfname,
+#endif
+#endif
+     O                    tr_seri)
+
+      USE ioipsl
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE comgeomphy
+      USE iophy
+      USE vampir
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+cAA Remarques en vrac:
+cAA--------------------
+cAA 1/ le call phytrac se fait avec nqmax-2 donc nous avons bien 
+cAA les vrais traceurs (nbtr) dans phytrac (pas la vapeur ni eau liquide)
+cAA 2/ Le choix du radon et du pb se fait juste avec un data 
+cAA    (peu propre). Peut-etre pourrait-on prevoir dans l'avenir 
+cAA    une variable "type de traceur" 
+c======================================================================
+#include "YOMCST.h"
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "indicesol.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "paramet.h"
+#include "control.h"
+cym#include "comgeomphy.h"
+#include "advtrac.h"
+#include "thermcell.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon  ! nombre de points horizontaux
+      integer nlev  ! nombre de couches verticales
+      integer nqmax ! nombre de traceurs auxquels on applique la physique
+      integer nstep  ! appel physique
+      integer julien !jour julien
+      integer itop_con(nlon)
+      integer ibas_con(nlon)
+      real gmtime
+      real pdtphys  ! pas d'integration pour la physique (seconde)
+      real t_seri(nlon,nlev) ! temperature
+      real tr_seri(nlon,nlev,nbtr) ! traceur  
+      real u(klon,klev)
+      real v(klon,klev)
+      real sh(nlon,nlev)     ! humidite specifique
+      real rh(nlon,nlev)     ! humidite relative
+      real cldliq(nlon,nlev) ! eau liquide nuageuse
+      real cldfra(nlon,nlev) ! fraction nuageuse (tous les nuages)
+      real diafra(nlon,nlev) ! fraction nuageuse (convection ou stratus artificiels)
+      real rneb(nlon,nlev)   ! fraction nuageuse (grande echelle)
+      real albsol(nlon)  ! albedo surface
+      real paprs(nlon,nlev+1)  ! pression pour chaque inter-couche (en Pa)
+      real ps(nlon)  ! pression surface
+      real pplay(nlon,nlev)  ! pression pour le mileu de chaque couche (en Pa)
+      real pphi(nlon,klev) ! geopotentiel
+      real pphis(klon)
+      REAL presnivs(klev)
+      logical debutphy       ! le flag de l'initialisation de la physique
+      logical lafin          ! le flag de la fin de la physique
+c Olivia      
+      integer nsplit
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)   !--lessivage convection
+      REAL prfl(klon,klev+1),   psfl(klon,klev+1)     !--lessivage large-scale
+
+#ifdef INCA
+      REAL flxmass_w(klon,klev)
+      CHARACTER(len=8) :: solsym(nqmax)
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      integer la
+      REAL              ::    tau_inca(klon,klev,9,2)
+      REAL              ::    piz_inca(klon,klev,9,2)
+      REAL              ::    cg_inca(klon,klev,9,2)
+      character*4       ::    rfname(9) 
+      REAL              ::    ccm(klon,klev,2) 
+#endif
+#endif
+c      integer iflag_con
+
+cAA Rem : nbtr : nombre de vrais traceurs est defini dans dimphy.h
+c
+c   convection:
+c   -----------
+c
+      REAL pmfu(nlon,nlev)  ! flux de masse dans le panache montant
+      REAL pmfd(nlon,nlev)  ! flux de masse dans le panache descendant
+      REAL pen_u(nlon,nlev) ! flux entraine dans le panache montant
+
+c
+c   thermiques:
+c   -----------
+c
+      real fm_therm(klon,klev+1),entr_therm(klon,klev)
+	real fm_therm1(klon,klev)
+c
+      REAL pde_u(nlon,nlev) ! flux detraine dans le panache montant
+      REAL pen_d(nlon,nlev) ! flux entraine dans le panache descendant
+      REAL pde_d(nlon,nlev) ! flux detraine dans le panache descendant
+c KE
+      real da(nlon,nlev),phi(nlon,nlev,nlev),mp(nlon,nlev)
+      REAL upwd(nlon,nlev)      ! saturated updraft mass flux
+      REAL dnwd(nlon,nlev)      ! saturated downdraft mass flux
+
+c
+c   Couche limite:
+c   --------------
+c
+      REAL coefh(nlon,nlev) ! coeff melange CL
+      REAL yu1(nlon)        ! vents au premier niveau
+      REAL yv1(nlon)        ! vents au premier niveau
+      REAL xlat(nlon)       ! latitudes pour chaque point 
+      REAL xlon(nlon)       ! longitudes pour chaque point 
+
+c
+c   Lessivage:
+c   ----------
+c
+c pour le ON-LINE
+c
+      REAL frac_impa(nlon,nlev)  ! fraction d'aerosols impactes
+      REAL frac_nucl(nlon,nlev)  ! fraction d'aerosols nuclees
+c
+cAA
+cAA Arguments necessaires pour les sources et puits de traceur:
+cAA ----------------
+cAA
+      real ftsol(nlon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(nlon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c abder
+      real pftsol1(nlon),pftsol2(nlon),pftsol3(nlon),pftsol4(nlon)
+      real ppsrf1(nlon),ppsrf2(nlon),ppsrf3(nlon),ppsrf4(nlon)
+c fin
+cAA ----------------------------
+cAA  VARIABLES LOCALES TRACEURS
+cAA ----------------------------
+cAA
+cAA Sources et puits des traceurs:
+cAA ------------------------------
+cAA
+cAA Pour l'instant seuls les cas du rn et du pb ont ete envisages.
+
+      REAL source(klon,nqmax)       ! a voir lorsque le flux est prescrit 
+cAA 
+cAA Pour la source de radon et son reservoir de sol
+cAA ................................................
+ 
+      REAL,save,allocatable :: trs(:,:)    ! Conc. radon ds le sol
+c$OMP THREADPRIVATE(trs)
+cym      SAVE trs
+      REAL :: trs_tmp(klon_glo)
+      
+      REAL,save,allocatable :: masktr(:,:) ! Masque reservoir de sol traceur
+c                            Masque de l'echange avec la surface
+c                           (1 = reservoir) ou (possible => 1 )
+c$OMP THREADPRIVATE(masktr)
+cym      SAVE masktr
+      REAL,save,allocatable :: fshtr(:,:)  ! Flux surfacique dans le reservoir de sol
+c$OMP THREADPRIVATE(fshtr)
+cym      SAVE fshtr
+      REAL,save,allocatable :: hsoltr(:)      ! Epaisseur equivalente du reservoir de sol
+c$OMP THREADPRIVATE(hsoltr)
+cym      SAVE hsoltr
+      REAL,save,allocatable :: tautr(:)       ! Constante de decroissance radioactive
+c$OMP THREADPRIVATE(tautr)
+cym      SAVE tautr
+      REAL,save,allocatable :: vdeptr(:)      ! Vitesse de depot sec dans la couche Brownienne
+c$OMP THREADPRIVATE(vdeptr)
+cym      SAVE vdeptr
+      REAL,save,allocatable :: scavtr(:)      ! Coefficient de lessivage
+c$OMP THREADPRIVATE(scavtr)
+cym      SAVE scavtr
+cAA
+      CHARACTER*2 itn
+C maf ioipsl
+      CHARACTER*2 str2
+      INTEGER nhori, nvert
+      REAL zsto, zout, zjulian
+      INTEGER nid_tra
+      SAVE nid_tra
+c$OMP THREADPRIVATE(nid_tra)
+#ifdef INCA_AER
+      INTEGER nid_tra2,nid_tra3
+      SAVE nid_tra2,nid_tra3
+c$OMP THREADPRIVATE(nid_tra2,nid_tra3)
+#endif
+c     REAL x(klon,klev,nbtr+2) ! traceurs 
+      INTEGER ndex(1)
+      INTEGER ndex2d(iim*(jjm+1)),ndex3d(iim*(jjm+1)*klev)
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev)
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+c
+      integer itau_w   ! pas de temps ecriture = nstep + itau_phy
+c
+
+C
+C Variables liees a l'ecriture de la bande histoire : phytrac.nc
+c
+c      INTEGER ecrit_tra
+c      SAVE ecrit_tra 
+
+      logical ok_sync
+      parameter (ok_sync = .true.)
+C
+C nature du traceur
+c
+      logical,save,allocatable :: aerosol(:)  ! Nature du traceur
+c                            ! aerosol(it) = true  => aerosol 
+c                            ! aerosol(it) = false => gaz 
+c                            ! nat_trac(it) = 1. aerosol
+      logical,save,allocatable :: clsol(:)    ! clsol(it) = true => CL sol calculee
+      logical,save,allocatable :: radio(:)    ! radio(it)=true => decroisssance radioactive
+c$OMP THREADPRIVATE(aerosol,clsol,radio)  
+cym      save aerosol,clsol,radio
+C
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+c--modif convection tiedtke
+      INTEGER i, k, it
+      INTEGER iq, iiq
+      REAL delp(klon,klev)
+c--end modif
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c Variables locales pour effectuer les appels en serie
+c----------------------------------------------------
+c
+      REAL d_tr(klon,klev), d_trs(klon) ! tendances de traceurs 
+      REAL d_tr_cl(klon,klev,nbtr) ! tendance de traceurs  couche limite
+      REAL d_tr_cv(klon,klev,nbtr) ! tendance de traceurs  conv pour chq traceur
+      REAL d_tr_th(klon,klev,nbtr) ! la tendance des thermiques
+      REAL d_tr_dec(klon,klev,nbtr) ! la tendance de la decroissance 
+c                                   ! radioactive du rn - > pb 
+      REAL d_tr_lessi_impa(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par impaction
+      REAL d_tr_lessi_nucl(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par nucleation 
+      REAL fluxrn(klon,klev) 
+      REAL fluxpb(klon,klev) 
+      REAL pbimpa(klon,klev) 
+      REAL pbnucl(klon,klev) 
+      REAL rn(klon,klev) 
+      REAL pb(klon,klev) 
+      REAL flestottr(klon,klev,nbtr) ! flux de lessivage 
+c                                    ! dans chaque couche 
+      real zmasse(klon,klev)
+      real ztra_th(klon,klev)
+
+C
+      character*20 modname
+      character*80 abort_message
+c
+c   Controles
+c-------------
+      logical first,couchelimite,convection,lessivage,sorties,
+     s        rnpb,inirnpb
+      save first,couchelimite,convection,lessivage,
+     s        sorties,inirnpb
+c$OMP THREADPRIVATE(first,couchelimite,convection,lessivage,
+c$OMP+              sorties,inirnpb)
+c      data first,couchelimite,convection,lessivage,sorties
+c     s     /.true.,.true.,.false.,.true.,.true./
+c Olivia
+       data first,couchelimite,convection,lessivage,
+     s      sorties
+     s     /.true.,.true.,.true.,.true.,.true./
+
+
+#ifdef INCA
+      INTEGER           :: lastgas
+      INTEGER           :: ncsec
+      INTEGER           :: prt_flag_ts(nbtr)  
+
+      REAL, PARAMETER   :: dry_mass = 28.966
+      REAL, POINTER     :: hbuf(:)
+      REAL, ALLOCATABLE :: obuf(:)
+      REAL              :: calday
+      REAL              :: pdel(klon,klev)
+      REAL              :: dummy(klon,klev)
+#endif
+c
+c======================================================================
+
+#ifdef INCA
+      prt_flag_ts(:)=(/
+#ifdef INCA_CH4
+     .             1,1,1,0,0,1,1,1,1,1,
+     .             0,1,0,0,0,0,0,1,0,0,
+     .             0,1,1,1,1,0,1,1,1,0,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,0,0
+#ifdef INCA_AER 
+     .             ,1,1,1,1,0,1,1,1,1,0,
+     .             1,1,1,1,1,1,0,1,0,1,
+     .             1,1,1,1,0,1,0,1,1,1
+#endif
+#endif
+#ifdef INCA_NMHC
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1
+#ifdef INCA_AER 
+     .             ,1,1,1,1,0,1,1,1,1,0,
+     .             1,1,1,1,1,1,0,1,0,1,
+     .             1,1,1,1,0,1,0,1,1,1
+#endif
+#endif
+#if defined(INCA_AER) && !defined(INCA_CH4) && !defined(INCA_NMHC)
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1,1,1,1,1,1,1,1,1
+#endif
+#if defined(INCA) && !defined(INCA_CH4) && !defined(INCA_NMHC) && !defined(INCA_AER)
+     .             1,1,1,1,1,1,1,1,1,1,
+     .             1                                         
+#endif
+
+     .             /)
+      dummy(:,:) = 0.
+
+#endif
+         modname='phytrac'
+
+         ps(:)=paprs(:,1)
+
+         if (debutphy) then
+           allocate( trs(klon,nbtr) )
+	   allocate( masktr(klon,nbtr)) 
+           allocate( fshtr(klon,nbtr) )
+           allocate( hsoltr(nbtr))
+           allocate( tautr(nbtr))
+           allocate( vdeptr(nbtr))
+           allocate( scavtr(nbtr))
+           allocate( aerosol(nbtr))
+           allocate( clsol(nbtr))
+           allocate( radio(nbtr))
+
+
+c jg: c'est ca qu'on veut?????           
+          ecrit_tra = FLOAT(NINT(86400./pdtphys *ecritphy)) 
+          print*,'dans phytrac ',pdtphys,ecritphy,ecrit_tra
+
+         if(nbtr.lt.nqmax) then
+c           print*,'NQMAX=',nqmax
+c           print*,'NBTR=',nbtr
+           abort_message='See above'
+           call abort_gcm(modname,abort_message,1)
+         endif
+
+         inirnpb=rnpb
+         PRINT*, 'La frequence de sortie traceurs est  ', ecrit_tra
+C         
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+#include "ini_histrac.h"
+#endif
+
+c======================================================================
+c   Initialisation de certaines variables pour le Rn et le Pb 
+c======================================================================
+
+c Initialisation du traceur dans le sol (couche limite radonique)
+c
+c        print*,'valeur de debut dans phytrac :',debutphy
+         trs(:,:) = 0.
+c$OMP MASTER         
+       if (is_mpi_root) then
+         trs_tmp(:)=0.
+	 open (99,file='starttrac',status='old',
+     .         err=999,form='formatted')
+         read(99,*) (trs_tmp(i),i=1,klon_glo)
+999      close(99)
+       endif
+c$OMP END MASTER
+       call Scatter(trs_tmp,trs(:,1))
+
+c         print*, 'apres starttrac'
+
+c Initialisation de la fraction d'aerosols lessivee
+c
+         d_tr_lessi_impa(:,:,:) = 0.
+         d_tr_lessi_nucl(:,:,:) = 0. 
+c
+c Initialisation de la nature des traceurs
+c
+         DO it = 1, nqmax
+            aerosol(it) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
+            radio(it) = .FALSE.    ! Par defaut pas de passage par radiornpb
+            clsol(it) = .FALSE.  ! Par defaut couche limite avec flux prescrit
+         ENDDO
+c
+      ENDIF  ! fin debutphy 
+c Initialisation du traceur dans le sol (couche limite radonique)
+      if(inirnpb) THEN
+c
+         radio(1)= .true.
+         radio(2)= .true.
+         clsol(1)= .true.
+         clsol(2)= .true.
+         aerosol(2) = .TRUE. ! le Pb est un aerosol 
+c
+         call initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+         inirnpb=.false.
+      endif
+#ifdef INCA
+      call VTe(VTphysiq)
+      call VTb(VTinca)
+!======================================================================
+!     Chimie
+!======================================================================
+
+        calday = FLOAT(julien) + gmtime
+        ncsec  = NINT (86400.*gmtime)
+
+        DO k = 1, nlev
+        pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+        END DO
+
+#ifdef INCAINFO
+        PRINT *, 'CHEMMAIN @ ', calday, ' ... '
+        DO it = 1, nbtr
+        PRINT *, solsym(it), MINVAL(tr_seri(:,:,it)),
+     $                       MAXVAL(tr_seri(:,:,it))
+      END DO
+#endif
+
+
+#ifdef INCA_AER
+        CALL aerosolmain (tr_seri,
+     $                 pdtphys,
+     $                 pplay,
+     $                 pdel,
+     $                 prfl,
+     $                 pmflxr,
+     $                 psfl,
+     $                 pmflxs,
+     $                 pmfu,
+     $                 itop_con,
+     $                 ibas_con,
+     $                 pphi,
+     $                 airephy, ! paire,
+     $                 nstep,
+     $                 rneb,         ! for chimiaq
+     $                 t_seri,       ! for chimiaq
+     $                 rh,
+#ifdef CPP_COUPLE
+     $                 tau_inca,
+     $                 piz_inca,
+     $                 cg_inca,
+     $                 rfname,
+     $                 ccm,
+#endif
+     $                 lafin)
+#endif
+
+        CALL chemmain (tr_seri,    !mmr
+     $                 nstep,      !nstep
+     $                 calday,     !calday
+     $                 julien,     !ncdate
+     $                 ncsec,      !ncsec
+     $                 1,          !lat
+     $                 pdtphys,    !delt
+     $                 paprs(1,1), !ps
+     $                 pplay,      !pmid
+     $                 pdel,       !pdel
+     $                 airephy,
+     $                 pctsrf(1,1),!oro
+     $                 ftsol,      !tsurf
+     $                 albsol,     !albs
+     $                 pphi,       !zma
+     $                 pphis,      !phis
+     $                 cldfra,     !cldfr
+     $                 rneb,       !cldfr_st
+     $                 diafra,     !cldfr_cv
+     $                 itop_con,   !cldtop
+     $                 ibas_con,   !cldbot
+     $                 cldliq,     !cwat
+     $                 prfl,       !flxrst
+     $                 pmflxr,     !flxrcv
+     $                 psfl,       !flxsst
+     $                 pmflxs,     !flxscv
+     $                 pmfu,       !flxupd
+     $                 flxmass_w,  !flxmass_w
+     $                 t_seri,     !tfld
+     $                 sh,         !sh
+     $                 rh,         !rh
+     $                 .false.,    !wrhstts
+     $                 hbuf,       !hbuf
+     $                 obuf,       !obuf
+     $                 iip1,       !nx
+     $                 jjp1,       !ny
+     $                 source,
+     $                 solsym)
+#ifdef INCAINFO
+#ifdef INCA_AER
+
+c Budget calculation for aerosol species
+CALL tbudget(airephy,pdtphys,nstep,tr_seri,.false.)
+
+c-- summary info----------------------------------------------------------------
+
+if (MOD(nstep,nint(86400./pdtphys)) .eq. 0) then
+print *, "global aerosol optical thickness "
+
+write (form,'(A,I2,A)') "(A,",trnx-trmx+1,"A10)"
+print form,"lamba [nm] ", (solsym(it),it=trmx,trnx)
+
+write (form,'(A,I2,A)') "(I11,",trnx-trmx+1,"F10.4)"
+do i=1,las
+print form,int(lambda(i)),(sum(tausum(:,i,it)*airephy)/sum(airephy),it=trmx,trnx)
+enddo
+
+print *,"global mean angstroem component ", sum(angst*airephy)/sum(airephy)
+endif
+#endif
+#endif
+
+#ifdef INCAINFO
+      PRINT *, 'OK.'
+      DO it = 1, nbtr
+      PRINT *, solsym(it), MINVAL(tr_seri(:,:,it)),
+     $                     MAXVAL(tr_seri(:,:,it))
+      END DO
+#endif
+      call VTe(VTinca)
+      call VTb(VTphysiq)
+#else
+
+c Abder
+ctestmaf      if(nqmax.gt.2) aerosol(3)=.true.
+
+       do i=1,nlon
+          pftsol1(i) = ftsol(i,1)
+          pftsol2(i) = ftsol(i,2)
+          pftsol3(i) = ftsol(i,3)
+          pftsol4(i) = ftsol(i,4)
+
+          ppsrf1(i) = pctsrf(i,1)
+          ppsrf2(i) = pctsrf(i,2)
+          ppsrf3(i) = pctsrf(i,3)
+          ppsrf4(i) = pctsrf(i,4)
+
+      enddo
+c Abder
+#endif
+c======================================================================
+c   Calcul de l'effet de la convection
+c======================================================================
+c     print*,'Avant convection'
+c      do it=1,nqmax
+c         WRITE(itn,'(i2)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+c      enddo
+
+      if (convection) then
+
+c      print*,'Pas de temps dans phytrac : ',pdtphys
+      DO it=1, nqmax
+#ifdef INCA
+      IF ( conv_flg(it) == 0 ) CYCLE
+#endif
+      if (iflag_con.eq.2) then
+c tiedke
+      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .            pplay, paprs, tr_seri(1,1,it), d_tr_cv(1,1,it))
+      else if (iflag_con.eq.3) then
+c KE
+      call cvltr(pdtphys, da, phi, mp, paprs,pplay, tr_seri(1,1,it),
+     .           upwd,dnwd,d_tr_cv(1,1,it))
+      endif
+
+      DO k = 1, nlev
+      DO i = 1, klon
+         tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it)
+      ENDDO
+      ENDDO
+#ifdef INCA
+      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '
+     .                              //solsym(it))
+#else
+      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it = '//itn)
+#endif
+      ENDDO
+c      print*,'apres nflxtr'
+
+      endif ! convection
+c        print*,'Apres convection'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+c      enddo
+
+
+c======================================================================
+c   Calcul de l'effet des thermiques
+c======================================================================
+
+      do k=1,klev
+         do i=1,klon
+            zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
+         enddo
+      enddo
+
+c      print*,'masse dans ph ',zmasse
+      do it=1,nqmax
+         do k=1,klev
+            do i=1,klon
+               d_tr_th(i,k,it)=0.
+               tr_seri(i,k,it)=max(tr_seri(i,k,it),0.)
+               tr_seri(i,k,it)=min(tr_seri(i,k,it),1.e10)
+            enddo
+         enddo
+      enddo
+
+      if (iflag_thermals.gt.0) then
+c        print*,'calcul de leffet des thermiques'
+        nsplit=10
+        DO it=1, nqmax
+c        WRITE(itn,'(i1)') it
+c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'conv it='//itn)
+c	     print*,'avant dqthermiquesretro'
+c             call dump2d(iim,jjm-1,tr_seri(2,1,1),'TR_SERI      ')
+
+         do isplit=1,nsplit
+c  Abderr 25 11 02
+C Thermiques 
+c	print*,'Avant dans phytrac'
+            call dqthermcell(klon,klev,pdtphys/nsplit
+     .       ,fm_therm,entr_therm,zmasse
+     .       ,tr_seri(1:klon,1:klev,it),d_tr,ztra_th)
+
+            do k=1,klev
+               do i=1,klon
+                  d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit
+                  d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k)
+                  tr_seri(i,k,it)=max(tr_seri(i,k,it)+d_tr(i,k),0.)
+               enddo
+            enddo
+          enddo ! nsplit
+c          print*,'apres thermiques'
+c             call dump2d(iim,jjm-1,d_tr_th(1,1,1),'d_tr_th      ')
+c            do k=1,klev
+c	print*,'d_tr_th(',k,')=',tr_seri(280,k,1)
+c	   enddo
+
+c        WRITE(itn,'(i1)') it
+c        CALL minmaxqfi(tr_seri(1,1,it),1.e10,-1.e33,'therm it='//itn)
+       ENDDO ! it
+       endif ! Thermiques
+c       print*,'ATTENTION: sdans thermniques'
+      
+c======================================================================
+c   Calcul de l'effet de la couche limite
+c======================================================================
+c	print *,'Avant couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
+      if (couchelimite) then
+
+      DO k = 1, nlev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k)-paprs(i,k+1)
+      ENDDO
+      ENDDO
+
+C maf modif pour tenir compte du cas rnpb + traceur
+      DO it=1, nqmax
+#ifdef INCA
+      IF ( pbl_flg(it) == 0 ) CYCLE
+#endif
+c     print *,'it',it,clsol(it)
+      if (clsol(it)) then  ! couche limite avec quantite dans le sol calculee
+          CALL cltracrn(it, pdtphys, yu1, yv1,
+     e                    coefh,t_seri,ftsol,pctsrf,
+     e                    tr_seri(1,1,it),trs(1,it),
+     e                    paprs, pplay, delp,
+     e                    masktr(1,it),fshtr(1,it),hsoltr(it),
+     e                    tautr(it),vdeptr(it),
+     e                    xlat,
+     s                    d_tr_cl(1,1,it),d_trs)
+          DO k = 1, nlev
+            DO i = 1, klon
+              tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+            ENDDO
+          ENDDO
+c
+c Traceur ds sol
+c
+          DO i = 1, klon
+            trs(i,it) = trs(i,it) + d_trs(i)
+          END DO
+C
+C maf provisoire suppression des prints
+C         WRITE(itn,'(i1)') it
+C         CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracrn it='//itn)
+      else ! couche limite avec flux prescrit
+#ifndef INCA
+
+Cmaf provisoire source / traceur a creer
+        DO i=1, klon
+          source(i,it) = 0.0 ! pas de source, pour l'instant
+        ENDDO
+C
+#endif
+          CALL cltrac(pdtphys, coefh,t_seri,
+     s               tr_seri(1,1,it), source(:,it),
+     e               paprs, pplay, delp,
+     s               d_tr_cl(1,1,it))
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+               ENDDO
+            ENDDO
+Cmaf          WRITE(itn,'(i1)') it
+cmaf          CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracn it='//itn)
+      endif
+      ENDDO
+c
+      endif ! couche limite
+
+c      print*,'Apres couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
+c======================================================================
+c   Calcul de l'effet du puits radioactif
+c======================================================================
+
+C MAF il faudrait faire une modification pour passer dans radiornpb 
+c si radio=true mais pour l'instant radiornpb propre au cas rnpb
+      if(rnpb) then
+c       print *, 'decroissance radiactive activee'
+        call radiornpb (tr_seri,pdtphys,tautr,d_tr_dec)
+C
+        DO it=1,nqmax
+            if(radio(it)) then
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
+               ENDDO
+            ENDDO
+            WRITE(itn,'(i1)') it
+            CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'puits rn it='//itn)
+            endif
+        ENDDO
+c
+      endif ! rnpb decroissance  radioactive
+C
+c======================================================================
+c   Calcul de l'effet de la precipitation
+c======================================================================
+
+c      print*,'LESSIVAGE =',lessivage
+      IF (lessivage) THEN
+
+c     print*,'avant lessivage'
+
+          d_tr_lessi_nucl(:,:,:) = 0. 
+          d_tr_lessi_impa(:,:,:) = 0. 
+          flestottr(:,:,:) = 0. 
+c
+c tendance des aerosols nuclees et impactes 
+c
+       DO it = 1, nqmax
+         IF (aerosol(it)) THEN
+           DO k = 1, nlev
+              DO i = 1, klon
+               d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +
+     s                  ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+               d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +
+     s                  ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c
+c Mises a jour des traceurs + calcul des flux de lessivage 
+c Mise a jour due a l'impaction et a la nucleation
+c
+c      call dump2d(iim,jjm-1,frac_impa(2:klon-1,10),'FRACIMPA')
+c      call dump2d(iim,jjm-1,frac_nucl(2:klon-1,10),'FRACNUCL')
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3')
+       DO it = 1, nqmax
+c         print*,'IT=',it,aerosol(it)
+         IF (aerosol(it)) THEN
+c           print*,'IT=',it,' On lessive'
+           DO k = 1, nlev
+              DO i = 1, klon
+               tr_seri(i,k,it)=tr_seri(i,k,it)
+     s         *frac_impa(i,k)*frac_nucl(i,k)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3B')
+c
+c Flux lessivage total 
+c
+      DO it = 1, nqmax
+           DO k = 1, nlev
+            DO i = 1, klon
+               flestottr(i,k,it) = flestottr(i,k,it) -
+     s                   ( d_tr_lessi_nucl(i,k,it)   +
+     s                     d_tr_lessi_impa(i,k,it) ) *
+     s                   ( paprs(i,k)-paprs(i,k+1) ) / 
+     s                   (RG * pdtphys)
+            ENDDO
+           ENDDO
+c
+Cmaf        WRITE(itn,'(i1)') it
+Cmaf    CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'tr(lessi) it='//itn)
+      ENDDO
+c
+c     print*,'apres lessivage'
+      ENDIF
+Cc
+      DO k = 1, nlev
+         DO i = 1, klon
+            fluxrn(i,k) = flestottr(i,k,1)
+            fluxpb(i,k) = flestottr(i,k,2)
+            rn(i,k) = tr_seri(i,k,1)
+            pb(i,k) = tr_seri(i,k,2)
+            pbnucl(i,k)=d_tr_lessi_nucl(i,k,2)
+            pbimpa(i,k)=d_tr_lessi_impa(i,k,2)
+         ENDDO
+      ENDDO
+
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+
+#ifdef CPP_IOIPSL
+#include "write_histrac.h"
+#endif
+
+c=============================================================
+
+      if (lafin) then
+         print*, 'c est la fin de la physique'
+	 call Gather(trs(:,1),trs_tmp)
+c$OMP MASTER	 
+	 if (is_mpi_root) then
+         
+	   open (99,file='restarttrac',  form='formatted')
+           do i=1,klon_glo
+               write(99,*) trs_tmp(i)
+           enddo
+           PRINT*, 'Ecriture du fichier restarttrac'
+           close(99)
+	 endif
+c$OMP END MASTER
+      else
+c         print*, 'physique pas fini'
+      endif
+
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/plevel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/plevel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/plevel.F	(revision 984)
@@ -0,0 +1,128 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cy#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cym      INTEGER lt(klon), lb(klon)
+cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb
+c$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+c$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+c$OMP THREADPRIVATE(first)
+      INTEGER i, k
+c
+      if (first) then
+        allocate(lt(klon),lb(klon),aist(klon),aisb(klon))
+	first=.false.
+      endif
+      
+c=====================================================================
+      if (lnew) then
+c   on r�nitialise les r�ndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, klon
+         IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, klon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+            IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, klon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Fr��ic Hourdin (3/01/02)
+
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,klon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, klon
+         if (pgcm(i,1).LT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/printflag.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/printflag.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/printflag.F	(revision 984)
@@ -0,0 +1,183 @@
+!
+! $Header$
+!
+       SUBROUTINE  printflag( tabcntr0, radpas, 
+     ,                        ok_journe,ok_instan,ok_region        )
+c
+
+c
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+       REAL tabcntr0( 100 )
+       LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
+       LOGICAL ok_orolf0,ok_limitvr0
+       LOGICAL ok_journe,ok_instan,ok_region
+       INTEGER radpas , radpas0
+c
+#include "clesphys.h"
+c
+c
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT *,' ********   Choix  des principales  cles de la physique 
+     ,   *********'
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+       PRINT 10, cycle_diurne,  soil_model  
+       PRINT 100
+
+       IF   (    iflag_con.EQ. 1 )   THEN
+           PRINT *,' *****           Shema  convection   LMD            
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 2 )   THEN
+           PRINT *,' *****           Shema  convection  Tiedtke  
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 3 )   THEN
+           PRINT *,' *****           Shema  convection    CCM      
+     ,          ******'
+       ENDIF
+       PRINT 100
+
+       PRINT 11, new_oliq, ok_orodr, ok_orolf   
+       PRINT 100
+
+       PRINT 7,  ok_limitvrai   
+       PRINT 100
+
+       PRINT 12, nbapp_rad
+       PRINT 100
+
+       PRINT 8, radpas
+       PRINT 100
+
+       PRINT 4,ok_journe,ok_instan,ok_region
+       PRINT 100
+       PRINT 100
+c
+c
+        cycle_diurn0  = .FALSE.
+        soil_model0   = .FALSE.
+        new_oliq0     = .FALSE.
+        ok_orodr0     = .FALSE.
+        ok_orolf0     = .FALSE.
+        ok_limitvr0   = .FALSE.
+
+        IF( tabcntr0( 7 ).EQ. 1. )   cycle_diurn0 = .TRUE.
+        IF( tabcntr0( 8 ).EQ. 1. )    soil_model0 = .TRUE.
+        IF( tabcntr0( 9 ).EQ. 1. )      new_oliq0 = .TRUE.
+        IF( tabcntr0(10 ).EQ. 1. )      ok_orodr0 = .TRUE.
+        IF( tabcntr0(11 ).EQ. 1. )      ok_orolf0 = .TRUE.
+        IF( tabcntr0(12 ).EQ. 1. )    ok_limitvr0 = .TRUE.
+
+        PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+     ,$$$$$$$$$$$$$'
+        PRINT 100
+c
+       IF( INT( tabcntr0( 5 ) ) .NE. iflag_con  )   THEN
+        PRINT 20, INT(tabcntr0(5)), iflag_con
+        PRINT 100
+       ENDIF
+
+       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
+        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
+        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+        PRINT 100
+        PRINT 22, radpas0, radpas
+        PRINT 100
+       ENDIF
+
+       IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND.
+     ,        cycle_diurne )     THEN
+        PRINT 13, cycle_diurn0, cycle_diurne
+        PRINT 100
+       ENDIF
+
+       IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND.
+     ,        soil_model )     THEN
+        PRINT 14, soil_model0, soil_model
+        PRINT 100
+       ENDIF
+
+       IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND.
+     ,        new_oliq )     THEN
+        PRINT 16, new_oliq0, new_oliq
+        PRINT 100
+       ENDIF
+
+       IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND.
+     ,        ok_orodr )     THEN
+        PRINT 15, ok_orodr0, ok_orodr
+        PRINT 100
+       ENDIF
+
+       IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND.
+     ,        ok_orolf )     THEN
+        PRINT 17, ok_orolf0, ok_orolf
+        PRINT 100
+       ENDIF
+
+       IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0.
+     ,     AND.ok_limitvrai )     THEN
+        PRINT 18, ok_limitvr0, ok_limitvrai
+        PRINT 100
+       ENDIF
+
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+
+ 4    FORMAT(2x,5(1H*),'  ok_journe= ',l3,3x,',ok_instan = ',
+     , l3,3x,',ok_region = ',l3,3x,5(1H*) )
+
+ 7     FORMAT(2x,5(1H*),15x,'      ok_limitvrai   = ',l3,16x,5(1h*) )
+
+ 8     FORMAT(2x,'*****             radpas    =                      ' ,
+     , i4,6x,' *****')
+
+ 10    FORMAT(2x,5(1H*),'    Cycle_diurne = ',l3,4x,', Soil_model = ',
+     , l3,12x,6(1H*) )
+
+
+ 11    FORMAT(2x,5(1H*),'  new_oliq = ',l3,3x,', Ok_orodr = ',
+     , l3,3x,', Ok_orolf = ',l3,3x,5(1H*) )
+
+
+ 12    FORMAT(2x,'*****  Nb d appels /jour des routines de rayonn. = ' ,
+     , i4,6x,' *****')
+
+ 13    FORMAT(2x,'$$$$$$$$   Attention !!  cycle_diurne  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 14    FORMAT(2x,'$$$$$$$$   Attention !!    soil_model  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 15    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orodr  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 16    FORMAT(2x,'$$$$$$$$   Attention !!      new_oliq  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 17    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orolf  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 18    FORMAT(2x,'$$$$$$$$   Attention !!  ok_limitvrai  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 20    FORMAT(/2x,'$$$$$$$$   Attention !!    iflag_con  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 21    FORMAT(2x,'$$$$$$$$   Attention !!     nbapp_rad  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 22    FORMAT(2x,'$$$$$$$$   Attention !!        radpas  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 100   FORMAT(/)
+
+       RETURN
+       END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.160.98.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.160.98.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.160.98.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=78,kflev=klev) ! 78*199
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.192.143.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.192.143.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.192.143.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+       INTEGER kdlon, kflev
+      PARAMETER (kdlon=10,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.32.24.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.32.24.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.32.24.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.48.32.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.48.32.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.48.32.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.72.46.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.72.46.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.72.46.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=1621,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.96.72.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.96.72.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.96.72.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=487,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.defaut.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.defaut.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.defaut.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddim.h	(revision 984)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/raddimlw.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/raddimlw.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/raddimlw.h	(revision 984)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+      INTEGER NUA
+      PARAMETER (NUA=24)
+      INTEGER NTRA
+      PARAMETER (NTRA=15)
+      INTEGER Ninter
+      PARAMETER (Ninter=6)
+      INTEGER NG1, NG1P1
+      PARAMETER (NG1=2, NG1P1=NG1+1)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/radepsi.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/radepsi.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/radepsi.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      REAL*8 ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW
+      REAL*8 ZEPSEC, ZEPSCR
+      PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines)
+      PARAMETER (ZEPSC  = 1.E-20)
+      PARAMETER (ZEPSCO = 1.E-10)
+      PARAMETER (ZEPSCQ = 1.E-10)
+      PARAMETER (ZEPSCT = 1.E-20)
+      PARAMETER (ZEPSCW = 1.E-20)
+      PARAMETER (ZEPSEC = 1.0E-12)
+      PARAMETER (ZEPSCR = 1.0E-10)
+c
+      REAL*8 REPSCT
+      PARAMETER (REPSCT=1.0E-10)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/radiornpb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/radiornpb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/radiornpb.F	(revision 984)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE radiornpb(tr,dtime,tautr,d_tr) 
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: Decroissance radioactive d'un traceur dans l'atmosphere
+CG240694 : Pour un traceur, le radon
+CG161294 : Plus un 2eme traceur, le 210Pb. Le radon decroit en plomb.
+c======================================================================
+c Arguments:
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c======================================================================
+C
+      INTEGER i , k , it
+      REAL tr(klon,klev,nbtr) , d_tr(klon,klev,nbtr)
+      REAL dtime
+      REAL tautr(nbtr)
+C
+c      WRITE(*,'(''PASSAGE radiornpb ... '',$)')
+C Attention, pour un pas de temps beaucoup plus petit que la decroissance!!!
+
+      DO it = 1,2
+           IF ( tautr(it) .GT. 0. ) THEN
+          	DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
+                END DO
+                END DO
+           ELSE
+                DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = 0.
+                END DO
+                END DO
+           END IF
+      END DO
+C
+CG161294 : Cas particulier radon 1 => plomb 2
+c
+      DO k = 1,klev
+        DO i = 1,klon
+          d_tr(i,k,2) = d_tr(i,k,2) - d_tr(i,k,1)
+        ENDDO
+      ENDDO
+c
+c      WRITE(*,*) ' radiornpb OK'
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/radlwsw.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/radlwsw.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/radlwsw.F	(revision 984)
@@ -0,0 +1,6572 @@
+!
+! $Header$
+!
+      SUBROUTINE radlwsw(dist, rmu0, fract, 
+     .                  paprs, pplay,tsol,albedo, alblw, t,q,wo,
+     .                  cldfra, cldemi, cldtaupd,
+     .                  heat,heat0,cool,cool0,radsol,albpla,
+     .                  topsw,toplw,solsw,sollw,
+     .                  sollwdown,
+     .                  topsw0,toplw0,solsw0,sollw0,
+     .                  lwdn0, lwdn, lwup0, lwup,
+     .                  swdn0, swdn, swup0, swup,
+     .                  ok_ade, ok_aie,
+     .                  tau_ae, piz_ae, cg_ae,
+     .                  topswad, solswad,
+     .                  cldtaupi, topswai, solswai)
+c      
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
+c Objet: interface entre le modele et les rayonnements
+c Arguments:
+c dist-----input-R- distance astronomique terre-soleil
+c rmu0-----input-R- cosinus de l'angle zenithal
+c fract----input-R- duree d'ensoleillement normalisee
+c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
+c solaire--input-R- constante solaire (W/m**2)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c tsol-----input-R- temperature du sol (en K)
+c albedo---input-R- albedo du sol (entre 0 et 1)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (en kg/kg)
+c wo-------input-R- contenu en ozone (en kg/kg) correction MPL 100505
+c cldfra---input-R- fraction nuageuse (entre 0 et 1)
+c cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value)
+c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
+c ok_ade---input-L- apply the Aerosol Direct Effect or not?
+c ok_aie---input-L- apply the Aerosol Indirect Effect or not?
+c tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F)
+c cldtaupi-input-R- epaisseur optique des nuages dans le visible
+c                   calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller
+c                   droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd
+c                   it is needed for the diagnostics of the aerosol indirect radiative forcing      
+c
+c heat-----output-R- echauffement atmospherique (visible) (K/jour)
+c cool-----output-R- refroidissement dans l'IR (K/jour)
+c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
+c albpla---output-R- albedo planetaire (entre 0 et 1)
+c topsw----output-R- flux solaire net au sommet de l'atm.
+c toplw----output-R- ray. IR montant au sommet de l'atmosphere
+c solsw----output-R- flux solaire net a la surface
+c sollw----output-R- ray. IR montant a la surface
+c solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir)
+c topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir)
+c solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind)
+c topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind)
+c
+c ATTENTION: swai and swad have to be interpreted in the following manner:
+c ---------
+c ok_ade=F & ok_aie=F -both are zero
+c ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad
+c                        indirect is zero
+c ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+c                        direct is zero
+c ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+c                        aerosol direct forcing is F_{AD} = topswai-topswad
+c
+      
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOETHF.h"
+c
+      real rmu0(klon), fract(klon), dist
+cIM   real co2_ppm
+cIM   real solaire
+#include "clesphys.h" 
+c
+      real paprs(klon,klev+1), pplay(klon,klev)
+      real albedo(klon), alblw(klon), tsol(klon)
+      real t(klon,klev), q(klon,klev), wo(klon,klev)
+      real cldfra(klon,klev), cldemi(klon,klev), cldtaupd(klon,klev)
+      real heat(klon,klev), cool(klon,klev)
+      real heat0(klon,klev), cool0(klon,klev)
+      real radsol(klon), topsw(klon), toplw(klon)
+      real solsw(klon), sollw(klon), albpla(klon)
+      real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
+      real sollwdown(klon)
+cIM output 3D 
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+c
+      REAL*8 ZFLUP(KDLON,KFLEV+1)
+      REAL*8 ZFLDN(KDLON,KFLEV+1)
+      REAL*8 ZFLUP0(KDLON,KFLEV+1)
+      REAL*8 ZFLDN0(KDLON,KFLEV+1)
+c
+      REAL*8 zx_alpha1, zx_alpha2
+c
+#include "YOMCST.h"
+c
+      INTEGER k, kk, i, j, iof, nb_gr
+      EXTERNAL lw, sw
+c
+cIM ctes ds clesphys.h  REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
+      REAL*8 PSCT
+c
+      REAL*8 PALBD(kdlon,2), PALBP(kdlon,2)
+      REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
+      REAL*8 PPSOL(kdlon), PDP(kdlon,klev)
+      REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
+      REAL*8 PTAVE(kdlon,kflev)
+      REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev)
+      REAL*8 PAER(kdlon,kflev,5)
+      REAL*8 PCLDLD(kdlon,kflev)
+      REAL*8 PCLDLU(kdlon,kflev)
+      REAL*8 PCLDSW(kdlon,kflev)
+      REAL*8 PTAU(kdlon,2,kflev)
+      REAL*8 POMEGA(kdlon,2,kflev)
+      REAL*8 PCG(kdlon,2,kflev)
+c
+      REAL*8 zfract(kdlon), zrmu0(kdlon), zdist
+c
+      REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev)
+      REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev)
+      REAL*8 ztopsw(kdlon), ztoplw(kdlon)
+      REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
+cIM
+      REAL*8 zsollwdown(kdlon)
+c
+      REAL*8 ztopsw0(kdlon), ztoplw0(kdlon)
+      REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
+      REAL*8 zznormcp
+cIM output 3D : SWup, SWdn, LWup, LWdn
+      REAL swdn(klon,kflev+1),swdn0(klon,kflev+1)
+      REAL swup(klon,kflev+1),swup0(klon,kflev+1)
+      REAL lwdn(klon,kflev+1),lwdn0(klon,kflev+1)
+      REAL lwup(klon,kflev+1),lwup0(klon,kflev+1)
+c-OB
+cjq the following quantities are needed for the aerosol radiative forcings
+
+      real topswad(klon), solswad(klon) ! output: aerosol direct forcing at TOA and surface
+      real topswai(klon), solswai(klon) ! output: aerosol indirect forcing atTOA and surface
+      real tau_ae(klon,klev,2), piz_ae(klon,klev,2), cg_ae(klon,klev,2) ! aerosol optical properties (see aeropt.F)
+      real cldtaupi(klon,klev)  ! cloud optical thickness for pre-industrial aerosol concentrations
+                                ! (i.e., with a smaller droplet concentrationand thus larger droplet radii)
+      logical ok_ade, ok_aie    ! switches whether to use aerosol direct (indirect) effects or not
+      real*8 tauae(kdlon,kflev,2) ! aer opt properties
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use
+      REAL*8 POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo
+      REAL*8 ztopswad(kdlon), zsolswad(kdlon) ! Aerosol direct forcing at TOAand surface
+      REAL*8 ztopswai(kdlon), zsolswai(kdlon) ! dito, indirect
+cjq-end
+!rv
+      tauae(:,:,:)=0.
+      pizae(:,:,:)=0.
+      cgae(:,:,:)=0.
+!rv
+      
+c
+c-------------------------------------------
+      nb_gr = klon / kdlon
+      IF (nb_gr*kdlon .NE. klon) THEN
+         PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr
+         CALL abort
+      ENDIF
+      IF (kflev .NE. klev) THEN
+          PRINT*, "kflev differe de klev, kflev, klev"
+          CALL abort
+      ENDIF
+c-------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         heat(i,k)=0.
+         cool(i,k)=0.
+         heat0(i,k)=0.
+         cool0(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      zdist = dist
+c
+cIM anciennes valeurs
+c     RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97
+c
+cIM : on met RCO2, RCH4, RN2O, RCFC11 et RCFC12 dans clesphys.h /lecture ds conf_phys.F90
+c     RCH4 = 1.65E-06* 16.043/28.97
+c     RN2O = 306.E-09* 44.013/28.97
+c     RCFC11 = 280.E-12* 137.3686/28.97
+c     RCFC12 = 484.E-12* 120.9140/28.97
+cIM anciennes valeurs
+c     RCH4 = 1.72E-06* 16.043/28.97
+c     RN2O = 310.E-09* 44.013/28.97
+c
+c     PRINT*,'IMradlwsw : solaire, co2= ', solaire, co2_ppm
+      PSCT = solaire/zdist/zdist
+c
+      DO 99999 j = 1, nb_gr
+      iof = kdlon*(j-1)
+c
+      DO i = 1, kdlon
+         zfract(i) = fract(iof+i)
+         zrmu0(i) = rmu0(iof+i)
+         PALBD(i,1) = albedo(iof+i)
+!         PALBD(i,2) = albedo(iof+i)
+         PALBD(i,2) = alblw(iof+i)
+         PALBP(i,1) = albedo(iof+i)
+!         PALBP(i,2) = albedo(iof+i)
+         PALBP(i,2) = alblw(iof+i)
+cIM cf. JLD pour etre en accord avec ORCHIDEE il faut mettre PEMIS(i) = 0.96
+         PEMIS(i) = 1.0 
+         PVIEW(i) = 1.66
+         PPSOL(i) = paprs(iof+i,1)
+         zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2)) 
+     .             / (pplay(iof+i,1)-pplay(iof+i,2))
+         zx_alpha2 = 1.0 - zx_alpha1
+         PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
+         PTL(i,klev+1) = t(iof+i,klev)
+         PDT0(i) = tsol(iof+i) - PTL(i,1)
+      ENDDO
+      DO k = 2, kflev
+      DO i = 1, kdlon
+         PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
+      ENDDO
+      ENDDO
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
+         PTAVE(i,k) = t(iof+i,k)
+         PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
+         PQS(i,k) = PWV(i,k)
+c wo:    cm.atm (epaisseur en cm dans la situation standard)
+c POZON: kg/kg
+         POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968
+     .               /(paprs(iof+i,k)-paprs(iof+i,k+1))
+     .               *(paprs(iof+i,1)/101325.0)
+         PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDSW(i,k) = cldfra(iof+i,k)
+         PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
+         POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
+         PCG(i,1,k) = 0.865
+         PCG(i,2,k) = 0.910
+c-OB
+cjq Introduced for aerosol indirect forcings.
+cjq The following values use the cloud optical thickness calculated from
+cjq present-day aerosol concentrations whereas the quantities without the
+cjq "A" at the end are for pre-industial (natural-only) aerosol concentrations
+cjq
+         PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k))
+         POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k))
+cjq-end
+      ENDDO
+      ENDDO
+c
+      DO k = 1, kflev+1
+      DO i = 1, kdlon
+         PPMB(i,k) = paprs(iof+i,k)/100.0
+      ENDDO
+      ENDDO
+c
+      DO kk = 1, 5
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PAER(i,k,kk) = 1.0E-15
+      ENDDO
+      ENDDO
+      ENDDO
+c-OB
+      DO k = 1, kflev
+      DO i = 1, kdlon
+        tauae(i,k,1)=tau_ae(iof+i,k,1)
+        pizae(i,k,1)=piz_ae(iof+i,k,1)
+        cgae(i,k,1) =cg_ae(iof+i,k,1)
+        tauae(i,k,2)=tau_ae(iof+i,k,2)
+        pizae(i,k,2)=piz_ae(iof+i,k,2)
+        cgae(i,k,2) =cg_ae(iof+i,k,2)
+      ENDDO
+      ENDDO
+c
+c======================================================================
+cIM ctes ds clesphys.h   CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      CALL LW(
+     .        PPMB, PDP,
+     .        PPSOL,PDT0,PEMIS,
+     .        PTL, PTAVE, PWV, POZON, PAER,
+     .        PCLDLD,PCLDLU,
+     .        PVIEW,
+     .        zcool, zcool0,
+     .        ztoplw,zsollw,ztoplw0,zsollw0,
+     .        zsollwdown,
+     .        ZFLUP, ZFLDN, ZFLUP0,ZFLDN0)
+cIM ctes ds clesphys.h   CALL SW(PSCT, RCO2, zrmu0, zfract,
+      CALL SW(PSCT, zrmu0, zfract,
+     S        PPMB, PDP,
+     S        PPSOL, PALBD, PALBP,
+     S        PTAVE, PWV, PQS, POZON, PAER,
+     S        PCLDSW, PTAU, POMEGA, PCG,
+     S        zheat, zheat0,
+     S        zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,
+     S        ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S        tauae, pizae, cgae, ! aerosol optical properties
+     s        PTAUA, POMEGAA,
+     s        ztopswad,zsolswad,ztopswai,zsolswai, ! diagnosed aerosol forcing
+     J        ok_ade, ok_aie) ! apply aerosol effects or not?
+
+c======================================================================
+      DO i = 1, kdlon
+         radsol(iof+i) = zsolsw(i) + zsollw(i)
+         topsw(iof+i) = ztopsw(i)
+         toplw(iof+i) = ztoplw(i)
+         solsw(iof+i) = zsolsw(i)
+         sollw(iof+i) = zsollw(i)
+         sollwdown(iof+i) = zsollwdown(i)
+cIM
+         DO k = 1, kflev+1
+         lwdn0 ( iof+i,k)   = ZFLDN0 ( i,k)
+         lwdn  ( iof+i,k)   = ZFLDN  ( i,k)
+         lwup0 ( iof+i,k)   = ZFLUP0 ( i,k)
+         lwup  ( iof+i,k)   = ZFLUP  ( i,k)
+         ENDDO
+c
+         topsw0(iof+i) = ztopsw0(i)
+         toplw0(iof+i) = ztoplw0(i)
+         solsw0(iof+i) = zsolsw0(i)
+         sollw0(iof+i) = zsollw0(i)
+         albpla(iof+i) = zalbpla(i)
+cIM
+         DO k = 1, kflev+1
+         swdn0 ( iof+i,k)   = ZFSDN0 ( i,k)
+         swdn  ( iof+i,k)   = ZFSDN  ( i,k)
+         swup0 ( iof+i,k)   = ZFSUP0 ( i,k)
+         swup  ( iof+i,k)   = ZFSUP  ( i,k)
+         ENDDO !k=1, kflev+1
+      ENDDO
+cjq-transform the aerosol forcings, if they have
+cjq to be calculated
+      IF (ok_ade) THEN
+      DO i = 1, kdlon
+         topswad(iof+i) = ztopswad(i)
+         solswad(iof+i) = zsolswad(i)
+      ENDDO
+      ELSE
+      DO i = 1, kdlon
+         topswad(iof+i) = 0.0
+         solswad(iof+i) = 0.0
+      ENDDO
+      ENDIF
+      IF (ok_aie) THEN
+      DO i = 1, kdlon
+         topswai(iof+i) = ztopswai(i)
+         solswai(iof+i) = zsolswai(i)
+      ENDDO
+      ELSE
+      DO i = 1, kdlon
+         topswai(iof+i) = 0.0
+         solswai(iof+i) = 0.0
+      ENDDO
+      ENDIF
+cjq-end
+      DO k = 1, kflev
+c      DO i = 1, kdlon
+c         heat(iof+i,k) = zheat(i,k)
+c         cool(iof+i,k) = zcool(i,k)
+c         heat0(iof+i,k) = zheat0(i,k)
+c         cool0(iof+i,k) = zcool0(i,k)
+c      ENDDO
+      DO i = 1, kdlon
+C        scale factor to take into account the difference between
+C        dry air and watter vapour scpecific heat capacity
+         zznormcp=1.0+RVTMP2*PWV(i,k)
+         heat(iof+i,k) = zheat(i,k)/zznormcp
+         cool(iof+i,k) = zcool(i,k)/zznormcp
+         heat0(iof+i,k) = zheat0(i,k)/zznormcp
+         cool0(iof+i,k) = zcool0(i,k)/zznormcp
+      ENDDO
+      ENDDO
+c
+99999 CONTINUE
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+      SUBROUTINE SW(PSCT, PRMU0, PFRAC, 
+     S              PPMB, PDP, 
+     S              PPSOL, PALBD, PALBP,
+     S              PTAVE, PWV, PQS, POZON, PAER,
+     S              PCLDSW, PTAU, POMEGA, PCG,
+     S              PHEAT, PHEAT0,
+     S              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
+     S              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S              tauae, pizae, cgae,
+     s              PTAUA, POMEGAA,
+     S              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
+     J              ok_ade, ok_aie )
+      USE dimphy      
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOMCST.h"
+C
+C     ------------------------------------------------------------------
+C
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT  ! constante solaire (valeur conseillee: 1370)
+cIM ctes ds clesphys.h   REAL*8 RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+#include "clesphys.h"
+C
+      REAL*8 PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL*8 PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+C
+      REAL*8 PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL*8 PFRAC(KDLON)  ! fraction de la journee
+C
+      REAL*8 PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL*8 PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL*8 PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL*8 POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+C
+      REAL*8 PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL*8 PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+C
+      REAL*8 PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL*8 PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL*8 PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL*8 POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+C
+      REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL*8 PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL*8 PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL*8 PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL*8 PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZOZ(KDLON,KFLEV)
+      REAL*8 ZAKI(KDLON,2)     
+      REAL*8 ZCLD(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON) 
+      REAL*8 ZDSIG(KDLON,KFLEV)
+      REAL*8 ZFACT(KDLON)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFDOWN(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1)
+      REAL*8 ZFUP(KDLON,KFLEV+1)
+      REAL*8 ZRMU(KDLON)
+      REAL*8 ZSEC(KDLON)
+      REAL*8 ZUD(KDLON,5,KFLEV+1)
+      REAL*8 ZCLDSW0(KDLON,KFLEV)
+c
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+C
+      INTEGER inu, jl, jk, i, k, kpl1
+c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+      SAVE itapsw,appel1er
+c$OMP THREADPRIVATE(appel1er)
+c$OMP THREADPRIVATE(itapsw)
+cjq-Introduced for aerosol forcings
+      real*8 flag_aer
+      logical ok_ade, ok_aie    ! use aerosol forcings or not?
+      real*8 tauae(kdlon,kflev,2)  ! aerosol optical properties
+      real*8 pizae(kdlon,kflev,2)  ! (see aeropt.F)
+      real*8 cgae(kdlon,kflev,2)   ! -"-
+      REAL*8 PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+      REAL*8 POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+      REAL*8 PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+      REAL*8 PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+      REAL*8 PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+      REAL*8 PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+cjq - Fluxes including aerosol effects
+      REAL*8,allocatable,save :: ZFSUPAD(:,:)
+c$OMP THREADPRIVATE(ZFSUPAD)
+      REAL*8,allocatable,save :: ZFSDNAD(:,:)
+c$OMP THREADPRIVATE(ZFSDNAD)
+      REAL*8,allocatable,save :: ZFSUPAI(:,:)
+c$OMP THREADPRIVATE(ZFSUPAI)
+      REAL*8,allocatable,save :: ZFSDNAI(:,:)
+c$OMP THREADPRIVATE(ZFSDNAI)
+      logical initialized
+cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+!rv
+      save flag_aer
+c$OMP THREADPRIVATE(flag_aer)
+      data initialized/.false./
+      save initialized
+c$OMP THREADPRIVATE(initialized)
+cjq-end
+      if(.not.initialized) then
+        flag_aer=0.
+        initialized=.TRUE.
+        allocate(ZFSUPAD(KDLON,KFLEV+1))
+        allocate(ZFSDNAD(KDLON,KFLEV+1))
+        allocate(ZFSUPAI(KDLON,KFLEV+1))
+        allocate(ZFSDNAI(KDLON,KFLEV+1))
+	ZFSUPAD(:,:)=0.
+        ZFSDNAD(:,:)=0.
+        ZFSUPAI(:,:)=0.
+        ZFSDNAI(:,:)=0.
+	
+      endif
+!rv
+      
+c
+      IF (appel1er) THEN
+         PRINT*, 'SW calling frequency : ', swpas
+         PRINT*, "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+c
+      DO JK = 1 , KFLEV
+      DO JL = 1, KDLON
+         ZCLDSW0(JL,JK) = 0.0
+         ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
+     .               *PDP(JL,JK)*(101325.0/PPSOL(JL))
+      ENDDO
+      ENDDO
+C
+C
+c clear-sky:
+cIM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+      CALL SWU(PSCT,ZCLDSW0,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+      flag_aer=0.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+
+c cloudy-sky:
+      
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+c      
+      IF (ok_ade) THEN
+c
+c cloudy-sky + aerosol dir OB
+      flag_aer=1.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO 
+      
+      ENDIF ! ok_ade
+      
+      IF (ok_aie) THEN
+         
+cjq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer=1.0
+      CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAI(JL,JK) = ZFSDN(JL,JK)          
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      ENDIF ! ok_aie      
+cjq -end
+      
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
+     .                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
+     .                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+c-OB
+         PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
+         PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
+c
+         PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
+         PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
+c-fin 
+      ENDDO
+C
+      RETURN
+      END
+c
+cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+      SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+     S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
+     S                PRMU,PSEC,PUD)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT
+cIM ctes ds clesphys.h   REAL*8 RCO2
+#include "clesphys.h"
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 PRMU0(KDLON)
+      REAL*8 PFRAC(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PFACT(KDLON)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(2)
+      REAL*8 ZC1J(KDLON,KFLEV+1)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZN175(KDLON)
+      REAL*8 ZN190(KDLON)
+      REAL*8 ZO175(KDLON)
+      REAL*8 ZO190(KDLON)
+      REAL*8 ZSIGN(KDLON)
+      REAL*8 ZR(KDLON,2) 
+      REAL*8 ZSIGO(KDLON)
+      REAL*8 ZUD(KDLON,2)
+      REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+C
+C* Prescribed Data:
+c
+      REAL*8 ZPDH2O,ZPDUMG
+      SAVE ZPDH2O,ZPDUMG
+c$OMP THREADPRIVATE(ZPDH2O,ZPDUMG)
+      REAL*8 ZPRH2O,ZPRUMG
+      SAVE ZPRH2O,ZPRUMG
+c$OMP THREADPRIVATE(ZPRH2O,ZPRUMG)
+      REAL*8 RTDH2O,RTDUMG
+      SAVE RTDH2O,RTDUMG
+c$OMP THREADPRIVATE(RTDH2O,RTDUMG)
+      REAL*8 RTH2O ,RTUMG
+      SAVE RTH2O ,RTUMG
+c$OMP THREADPRIVATE(RTH2O ,RTUMG)
+      DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /
+      DATA ZPRH2O,ZPRUMG / 30000., 30000. /
+      DATA RTDH2O,RTDUMG /  0.40  , 0.375 /
+      DATA RTH2O ,RTUMG  /  240.  , 240.  /
+C     ------------------------------------------------------------------
+C
+C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+C                 -----------------------------
+C
+ 100  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=2
+C      
+C
+C*         1.1    INITIALIZES QUANTITIES
+C                 ----------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+C
+C*          1.3    AMOUNTS OF ABSORBERS
+C                  --------------------
+C
+ 130  CONTINUE
+C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
+     .             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
+     .             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)
+     S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
+     S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+C      
+C
+C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+C                 -----------------------------------------------
+C
+ 140  CONTINUE
+C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+C
+      CALL SWTT1(2, 2, IIND, ZUD, ZR)
+C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW1S ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW
+     S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD  
+     S  ,  PFD   , PFU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)  
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+      REAL*8 PFD(KDLON,KFLEV+1)
+      REAL*8 PFU(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(4)
+C      
+      REAL*8 ZCGAZ(KDLON,KFLEV) 
+      REAL*8 ZDIFF(KDLON)
+      REAL*8 ZDIRF(KDLON)        
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZR(KDLON,4)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZW(KDLON,4)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+c
+c Prescribed Data:
+c
+      REAL*8 RSUN(2)
+      SAVE RSUN
+c$OMP THREADPRIVATE(RSUN)
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+c$OMP THREADPRIVATE(RRAY)
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C     ------------------------------------------------------------------
+C
+C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+C                 ----------------------- ------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
+     S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
+     S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL
+     S  , PSEC  ,PTAU
+     S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE
+     S  , ZTAUAZ,ZTRA1 ,ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    OZONE ABSORPTION
+C                ----------------
+C
+ 300  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+C      
+C
+C*         3.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 310  CONTINUE
+C
+      JAJ = 2
+C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
+     S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+C
+C
+C*         3.2   UPWARD FLUXES
+C                -------------
+C
+ 320  CONTINUE
+C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
+     S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
+     S          * RSUN(KNU)
+ 325  CONTINUE
+C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW2S ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW
+     S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU
+     S  ,  PUD   ,PWV , PQS
+     S  ,  PFDOWN,PFUP                                            )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+C     A GREY MOLECULAR ABSORPTION
+C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+C     OF ABSORBERS
+C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PQS(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PFDOWN(KDLON,KFLEV+1)
+      REAL*8 PFUP(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND2(2), IIND3(3)
+      REAL*8 ZCGAZ(KDLON,KFLEV)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1) 
+      REAL*8 ZG(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRL(KDLON,8)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZRUEF(KDLON,8)
+      REAL*8 ZR1(KDLON) 
+      REAL*8 ZR2(KDLON,2)
+      REAL*8 ZR3(KDLON,3)
+      REAL*8 ZR4(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZS(KDLON)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)   
+      REAL*8 ZW1(KDLON)
+      REAL*8 ZW2(KDLON,2)
+      REAL*8 ZW3(KDLON,3)
+      REAL*8 ZW4(KDLON)
+      REAL*8 ZW5(KDLON)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+C
+C* Prescribed Data:
+C
+      REAL*8 RSUN(2)
+      SAVE RSUN
+c$OMP THREADPRIVATE(RSUN)
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+c$OMP THREADPRIVATE(RRAY)
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C
+C     ------------------------------------------------------------------
+C
+C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+C                 -------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1
+     S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1
+     S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC 
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL
+     S  , PSEC  , PTAU
+     S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE
+     S  , ZTAUAZ, ZTRA1 , ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+C                ------------------------------------------------------
+C
+ 300  CONTINUE
+C
+      JN = 2
+C
+      DO 361 JABS=1,2
+C
+C
+C*         3.1  SURFACE CONDITIONS
+C               ------------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+C
+C
+C*         3.2  INTRODUCING CLOUD EFFECTS
+C               -------------------------
+C
+ 320  CONTINUE
+C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
+     S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
+     S               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+C
+      CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
+     S          ZRE1, ZRE2, ZTR1, ZTR2)
+C
+      DO 323 JL = 1, KDLON
+C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
+     S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
+     S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
+     S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
+     S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
+     S             + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
+     S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
+     S              * ZREFZ(JL,1,JKM1)))
+     S              * ZG(JL) * (1. -ZRNEB(JL))
+C
+ 323  CONTINUE
+ 324  CONTINUE
+C
+C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C               -------------------------------------------------
+C
+ 330  CONTINUE
+C
+      DO 351 JREF=1,2
+C
+      JN = JN + 1
+C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         4.    INVERT GREY AND CONTINUUM FLUXES
+C                --------------------------------
+C
+ 400  CONTINUE
+C
+C
+C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+C                ---------------------------------------------
+C
+ 410  CONTINUE
+C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+C
+C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+C                 ---------------------------------------------
+C
+ 420  CONTINUE
+C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+C
+C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+C                 --------------------------
+C
+ 4210 CONTINUE
+C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+C
+C*         4.2.2  TRANSMISSION FUNCTION
+C                 ---------------------
+C
+ 4220 CONTINUE
+C
+      CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
+C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+C
+C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+C                 ------------------------------------------------------
+C
+ 430  CONTINUE
+C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
+     S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
+     S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+C                ----------------------------------------
+C
+ 500  CONTINUE
+C
+C
+C*         5.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 510  CONTINUE
+C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 513 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+C
+C
+C*         5.2   UPWARD FLUXES
+C                -------------
+C
+ 520  CONTINUE
+C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 527 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+C                 --------------------------------------------------
+C
+ 600  CONTINUE
+      IABS=3
+C
+C*         6.1    DOWNWARD FLUXES
+C                 ---------------
+C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
+     S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
+     S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+C
+C
+C*         6.2    UPWARD FLUXES
+C                 -------------
+C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
+     S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
+     S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWCLR  ( KNU
+     S  , PAER  , flag_aer, tauae, pizae, cgae
+     S  , PALBP , PDSIG , PRAYL , PSEC
+     S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ  
+     S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CLEAR-SKY COLUMN
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 94-11-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real*8 flag_aer
+      real*8 tauae(kdlon,kflev,2)
+      real*8 pizae(kdlon,kflev,2)
+      real*8 cgae(kdlon,kflev,2)
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+C
+      REAL*8 PCGAZ(KDLON,KFLEV)     
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMU0(KDLON,KFLEV+1)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC0I(KDLON,KFLEV+1)       
+      REAL*8 ZCLE0(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS0(KDLON)
+      REAL*8 ZSCAT(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL*8 ZBMU0, ZBMU1, ZRE11
+C
+C* Prescribed Data for Aerosols:
+C
+      REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
+      SAVE TAUA, RPIZA, RCGA
+c$OMP THREADPRIVATE(TAUA, RPIZA, RCGA)
+      DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
+     S .730719, .912819, .725059, .745405, .682188 ,
+     S .730719, .912819, .725059, .745405, .682188 /
+      DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
+     S .872212, .982545, .623143, .944887, .997975 ,
+     S .872212, .982545, .623143, .944887, .997975 /
+      DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
+     S .647596, .739002, .580845, .662657, .624246 ,
+     S .647596, .739002, .580845, .662657, .624246 /
+C     ------------------------------------------------------------------
+C
+C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+C                --------------------------------------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+      DO 108 JK = 1 , KFLEV
+c-OB
+c      DO 104 JL = 1, KDLON
+c      PCGAZ(JL,JK) = 0.
+c      PPIZAZ(JL,JK) =  0.
+c      PTAUAZ(JL,JK) = 0.
+c 104  CONTINUE
+c-OB
+c      DO 106 JAE=1,5
+c      DO 105 JL = 1, KDLON
+c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+c 105  CONTINUE
+c 106  CONTINUE
+c-OB
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
+      PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
+      PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
+ 105  CONTINUE
+C
+      IF (flag_aer.GT.0) THEN
+c-OB
+      DO 107 JL = 1, KDLON
+c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
+     S                       / (1. - PPIZAZ(JL,JK) * ZFF)
+ 107  CONTINUE
+      ELSE
+      DO JL = 1, KDLON
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END DO
+      END IF   ! check flag_aer
+c     107  CONTINUE
+c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+C
+ 108  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
+     S            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
+     S  , PSEC  , PTAU
+     S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
+     S  , PTAUAZ, PTRA1 , PTRA2 )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CONTINUUM SCATTERING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+C
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMUE(KDLON,KFLEV+1)
+      REAL*8 PCGAZ(KDLON,KFLEV)
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC1I(KDLON,KFLEV+1)
+      REAL*8 ZCLEQ(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS1(KDLON)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)
+C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
+C
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
+     S            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.3  EFFECT OF CLOUD LAYER
+C               ---------------------
+C
+ 330  CONTINUE
+C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
+     S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+C machine
+C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+C
+      CALL SWDE(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
+     S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+C
+      DO 345 JL = 1, KDLON
+C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               * (1.-ZRNEB(JL))
+C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
+     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
+     S                 PRE1,PRE2,PTR1,PTR2)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+C
+C     METHOD.
+C     -------
+C
+C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      REAL*8 PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL*8 PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL*8 PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL*8 PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL*8 PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL*8 PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER jl
+      REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
+      REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL*8 ZRI0B, ZRI1B
+      REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
+C     ------------------------------------------------------------------
+C
+C*         1.      DELTA-EDDINGTON CALCULATIONS
+C
+ 100  CONTINUE
+C
+      DO 131 JL   =   1, KDLON
+C
+C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+C
+ 110  CONTINUE
+C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+CMAF      ZARG=MIN(ZTOP/PRMUZ(JL),200.)
+      ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
+      ZEXMU0=EXP(-ZARG)
+CMAF      ZARG2=MIN(ZRK*ZTOP,200.)
+      ZARG2=MIN(ZRK*ZTOP,2.0d+2)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+C
+C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+C
+ 120  CONTINUE
+C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+C
+C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+C
+ 130  CONTINUE
+C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+C
+ 131  CONTINUE
+      RETURN
+      END
+      SUBROUTINE SWTT (KNU,KA,PU,PTR)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS
+C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL*8 PU(KDLON)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+c$OMP THREADPRIVATE(APAD, BPAD, D)
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
+     S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
+     S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
+     S      * ( APAD(KNU,KA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
+     S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
+     S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
+     S      * ( BPAD(KNU,KA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 95-01-20
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL*8 PU(KDLON,KABS)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON)
+      REAL*8 ZR2(KDLON)
+      REAL*8 ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+c$OMP THREADPRIVATE(APAD, BPAD, D)
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
+     S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
+     S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
+     S      * ( APAD(KNU,IA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
+     S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
+     S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
+     S      * ( BPAD(KNU,IA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+C
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      SUBROUTINE LW(
+     .              PPMB, PDP,
+     .              PPSOL,PDT0,PEMIS,
+     .              PTL, PTAVE, PWV, POZON, PAER,
+     .              PCLDLD,PCLDLU,
+     .              PVIEW,
+     .              PCOLR, PCOLR0,
+     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
+     .              psollwdown,
+cIM  .              psollwdown,psollwdownclr,
+cIM  .              ptoplwdown,ptoplwdownclr)
+     .              plwup, plwdn, plwup0, plwdn0)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+cIM ctes ds clesphys.h
+c     REAL*8 RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+c     REAL*8 RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+c     REAL*8 RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+c     REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+c     REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+#include "clesphys.h"
+      REAL*8 PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL*8 PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL*8 PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL*8 PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL*8 PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL*8 PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL*8 POZON(KDLON,KFLEV)   ! O3 CONCENTRATION (kg/kg)
+      REAL*8 PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL*8 PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL*8 PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL*8 PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL*8 PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+C
+      REAL*8 PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL*8 PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL*8 PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL*8 PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      REAL*8 PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+c Rajout LF
+      real*8 psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
+c Rajout IM
+cIM   real*8 psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
+cIM   real*8 ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
+cIM   real*8 ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
+cIM
+      REAL*8 plwup(KDLON,KFLEV+1)  ! LW up total sky
+      REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky
+      REAL*8 plwdn(KDLON,KFLEV+1)  ! LW down total sky
+      REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky
+C-------------------------------------------------------------------------
+      REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZOZ(KDLON,KFLEV)
+c
+cym      REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+cym      REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+cym      REAL*8 ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+cym      REAL*8 ZBSUI(KDLON)                    ! Intermediate variable
+cym      REAL*8,ZCTS(KDLON,KFLEV)               ! Intermediate variable
+cym      REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+      REAL*8,allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL*8,allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8,allocatable,save :: ZBINT(:,:)            ! Intermediate variable
+      REAL*8,allocatable,save :: ZBSUI(:)                    ! Intermediate variable
+      REAL*8,allocatable,save :: ZCTS(:,:)               ! Intermediate variable
+      REAL*8,allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
+c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+c
+      INTEGER ilim, i, k, kpl1
+C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+
+C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         PRINT*, "LW clear-sky calling frequency: ", lw0pas
+         PRINT*, "LW cloudy-sky calling frequency: ", lwpas
+         PRINT*, "   In general, they should be 1"
+cym
+	 allocate(ZFLUX(KDLON,2,KFLEV+1) )
+         allocate(ZFLUC(KDLON,2,KFLEV+1) )
+         allocate(ZBINT(KDLON,KFLEV+1))
+         allocate(ZBSUI(KDLON))
+         allocate(ZCTS(KDLON,KFLEV))
+         allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
+         appel1er=.FALSE.
+      ENDIF
+C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+      DO k = 1, KFLEV  ! convertir ozone de kg/kg en pa/pa
+      DO i = 1, KDLON
+c convertir ozone de kg/kg en pa (modif MPL 100505)
+         ZOZ(i,k) = POZON(i,k)*PDP(i,k) * RMD/RMO3
+c        print *,'LW: ZOZ*10**6=',ZOZ(i,k)*1000000.
+      ENDDO
+      ENDDO
+cIM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+      CALL LWU(
+     S         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
+     S          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
+     S         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
+     S         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
+     .                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
+     .                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+c
+         PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
+         PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
+c
+cIM attention aux signes !; LWtop >0, LWdn < 0
+         DO k = 1, KFLEV+1
+           plwup(i,k) = ZFLUX(i,1,k)
+           plwup0(i,k) = ZFLUC(i,1,k)
+           plwdn(i,k) = ZFLUX(i,2,k)
+           plwdn0(i,k) = ZFLUC(i,2,k)
+         ENDDO
+      ENDDO
+C     ------------------------------------------------------------------
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+      SUBROUTINE LWU(
+     S               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
+     S               PABCU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+C           TEMPERATURE EFFECTS
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+cIM ctes ds clesphys.h
+c     REAL*8 RCO2
+c     REAL*8 RCH4, RN2O, RCFC11, RCFC12
+#include "clesphys.h"
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PVIEW(KDLON)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+C
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZDUC(KDLON,3*KFLEV+1)
+      REAL*8 ZPHIO(KDLON)
+      REAL*8 ZPSC2(KDLON)
+      REAL*8 ZPSC3(KDLON)
+      REAL*8 ZPSH1(KDLON)
+      REAL*8 ZPSH2(KDLON)
+      REAL*8 ZPSH3(KDLON)
+      REAL*8 ZPSH4(KDLON)
+      REAL*8 ZPSH5(KDLON)
+      REAL*8 ZPSH6(KDLON)
+      REAL*8 ZPSIO(KDLON)
+      REAL*8 ZTCON(KDLON)
+      REAL*8 ZPHM6(KDLON)
+      REAL*8 ZPSM6(KDLON)
+      REAL*8 ZPHN6(KDLON)
+      REAL*8 ZPSN6(KDLON)
+      REAL*8 ZSSIG(KDLON,3*KFLEV+1)
+      REAL*8 ZTAVI(KDLON)
+      REAL*8 ZUAER(KDLON,Ninter)
+      REAL*8 ZXOZ(KDLON)
+      REAL*8 ZXWV(KDLON)
+C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL*8 zfppw, ztx, ztx2, zzably
+      REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL*8 zcac8, zcbc8
+      REAL*8 zalup, zdiff
+c
+      REAL*8 PVGCO2, PVGH2O, PVGO3
+C
+      REAL*8 R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+c
+c Used Data Block:
+c
+      REAL*8 TREF
+      SAVE TREF
+c$OMP THREADPRIVATE(TREF)
+      REAL*8 RT1(2)
+      SAVE RT1
+c$OMP THREADPRIVATE(RT1)
+      REAL*8 RAER(5,5)
+      SAVE RAER
+c$OMP THREADPRIVATE(RAER)
+      REAL*8 AT(8,3), BT(8,3)
+      SAVE AT, BT
+c$OMP THREADPRIVATE(AT, BT)
+      REAL*8 OCT(4)
+      SAVE OCT
+c$OMP THREADPRIVATE(OCT)
+      DATA TREF /250.0/
+      DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
+      DATA RAER / .038520, .037196, .040532, .054934, .038520
+     1          , .12613 , .18313 , .10357 , .064106, .126130
+     2          , .012579, .013649, .018652, .025181, .012579
+     3          , .011890, .016142, .021105, .028908, .011890
+     4          , .013792, .026810, .052203, .066338, .013792 /
+      DATA (AT(1,IR),IR=1,3) /
+     S 0.298199E-02,-.394023E-03,0.319566E-04 /
+      DATA (BT(1,IR),IR=1,3) /
+     S-0.106432E-04,0.660324E-06,0.174356E-06 /
+      DATA (AT(2,IR),IR=1,3) /
+     S 0.143676E-01,0.366501E-02,-.160822E-02 /
+      DATA (BT(2,IR),IR=1,3) /
+     S-0.553979E-04,-.101701E-04,0.920868E-05 /
+      DATA (AT(3,IR),IR=1,3) /
+     S 0.197861E-01,0.315541E-02,-.174547E-02 /
+      DATA (BT(3,IR),IR=1,3) /
+     S-0.877012E-04,0.513302E-04,0.523138E-06 /
+      DATA (AT(4,IR),IR=1,3) /
+     S 0.289560E-01,-.208807E-02,-.121943E-02 /
+      DATA (BT(4,IR),IR=1,3) /
+     S-0.165960E-03,0.157704E-03,-.146427E-04 /
+      DATA (AT(5,IR),IR=1,3) /
+     S 0.103800E-01,0.436296E-02,-.161431E-02 /
+      DATA (BT(5,IR),IR=1,3) /
+     S -.276744E-04,-.327381E-04,0.127646E-04 /
+      DATA (AT(6,IR),IR=1,3) /
+     S 0.868859E-02,-.972752E-03,0.000000E-00 /
+      DATA (BT(6,IR),IR=1,3) /
+     S -.278412E-04,-.713940E-06,0.117469E-05 /
+      DATA (AT(7,IR),IR=1,3) /
+     S 0.250073E-03,0.455875E-03,0.109242E-03 /
+      DATA (BT(7,IR),IR=1,3) /
+     S 0.199846E-05,-.216313E-05,0.175991E-06 /
+      DATA (AT(8,IR),IR=1,3) /
+     S 0.307423E-01,0.110879E-02,-.322172E-03 /
+      DATA (BT(8,IR),IR=1,3) /
+     S-0.108482E-03,0.258096E-05,-.814575E-06 /
+c
+      DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
+C-----------------------------------------------------------------------
+c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+C
+C
+C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+C                ------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
+     S  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+C                --------------------------------------------------
+C
+ 400  CONTINUE
+C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
+     S                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+C                --------------------------------------------------
+C
+ 500  CONTINUE
+C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+C
+C
+C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+C               --------------------------------------------------
+C
+ 510  CONTINUE
+C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
+     S      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
+     S      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
+     S      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+C
+C
+C
+C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+C               --------------------------------------------------
+C
+ 520  CONTINUE
+C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+CMAF      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+CMAF      ZUP   = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
+      ZUP   = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
+     S                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
+     S                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
+     S                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
+     S                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
+     S                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
+     S                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
+     S                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
+     S                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
+     S                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+C
+      PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S               +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+      PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+      PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S               +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+      PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S               +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+C
+      PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+      PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+ 523  CONTINUE
+ 524  CONTINUE
+C
+ 529  CONTINUE
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
+     S                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C     PURPOSE.
+C     --------
+C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+C           SAVING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+C                                          MEMORY)
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER KLIM
+C
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PDT0(KDLON)
+      REAL*8 PEMIS(KDLON)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PTL(KDLON,KFLEV+1)
+      REAL*8 PTAVE(KDLON,KFLEV)
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1)
+C     
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 PBINT(KDLON,KFLEV+1)
+      REAL*8 PBSUI(KDLON)
+      REAL*8 PCTS(KDLON,KFLEV)
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+C
+C-------------------------------------------------------------------------
+C
+C* LOCAL VARIABLES:
+      REAL*8 ZB(KDLON,Ninter,KFLEV+1)
+      REAL*8 ZBSUR(KDLON,Ninter)
+      REAL*8 ZBTOP(KDLON,Ninter)
+      REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL*8 ZGA(KDLON,8,2,KFLEV)
+      REAL*8 ZGB(KDLON,8,2,KFLEV)
+      REAL*8 ZGASUR(KDLON,8,2)
+      REAL*8 ZGBSUR(KDLON,8,2)
+      REAL*8 ZGATOP(KDLON,8,2)
+      REAL*8 ZGBTOP(KDLON,8,2)
+C
+      INTEGER nuaer, ntraer
+C     ------------------------------------------------------------------
+C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB(PDT0,PTAVE,PTL,
+     S          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
+     S          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+C     ------------------------------------------------------------------
+C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV(NUAER,NTRAER, KLIM
+     R  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
+     R  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+C     ------------------------------------------------------------------
+      RETURN
+      END
+      SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
+     R               PBINT,PBSUIN,PCTS,PCNTRB,
+     S               PFLUX)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+C           RADIANCES
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+C PFLUC
+C     ==== OUTPUTS ===
+C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+C                     1  ==>  UPWARD   FLUX TOTAL
+C                     2  ==>  DOWNWARD FLUX TOTAL
+C
+C     METHOD.
+C     -------
+C
+C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+C     CLOUDS
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER klim
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL*8 PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+c
+      REAL*8 PCLDLD(KDLON,KFLEV)
+      REAL*8 PCLDLU(KDLON,KFLEV)
+      REAL*8 PEMIS(KDLON)
+C
+      REAL*8 PFLUX(KDLON,2,KFLEV+1)
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+C
+      REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
+     S  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
+     S  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
+C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL*8 zcfrac
+C     ------------------------------------------------------------------
+C
+C*         1.     INITIALIZATION
+C                 --------------
+C
+ 100  CONTINUE
+C
+      IMAXC = 0
+C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+C
+C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+C                 -------------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+CGM*******
+      IMAXC=KFLEV
+CGM*******
+C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+C                  ---------------------------------------
+C
+      IF (IMAXC.GT.0) THEN
+C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+C
+C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+C                  ------------------------------
+C
+ 200  CONTINUE
+C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+C
+C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+C                  ----------------------------------------------
+C
+ 210  CONTINUE
+C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+C
+C*         2.1.1   ABOVE THE CLOUD
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+C
+C*         2.1.2   BELOW THE CLOUD
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+C
+ 213     CONTINUE
+C
+C
+C*         2.2     CLOUD COVER MATRIX
+C                  ------------------
+C
+C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+C
+ 220  CONTINUE
+C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+C
+C
+C
+C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 240  CONTINUE
+C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+C
+C
+C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 250  CONTINUE
+C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+C
+C
+C
+C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+C                  ----------------------------------------------
+C
+ 300  CONTINUE
+C
+C*         3.1     DOWNWARD FLUXES
+C                  ---------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+C
+      DO 317 JK1 = KFLEV , 1 , -1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+C
+ 317  CONTINUE
+C
+C
+C
+C
+C*         3.2     UPWARD FLUX AT THE SURFACE
+C                  --------------------------
+C
+ 320  CONTINUE
+C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+C
+C
+C
+C*         3.3     UPWARD FLUXES
+C                  -------------
+C
+ 330  CONTINUE
+C
+      DO 337 JK1 = 2 , KFLEV+1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+C
+ 337  CONTINUE
+C
+C
+      END IF
+C
+C
+C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+C
+ 230  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+C
+      RETURN
+      END
+      SUBROUTINE LWB(PDT0,PTAVE,PTL
+     S  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
+     S  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES PLANCK FUNCTIONS
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+C     ==== OUTPUTS ===
+C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C
+C-----------------------------------------------------------------------
+C
+C ARGUMENTS:
+C
+      REAL*8 PDT0(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PTL(KDLON,KFLEV+1)
+C
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+C-------------------------------------------------------------------------
+C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL*8 zdsto1, zdstox, zdst1, zdstx
+c
+C* Quelques parametres:
+      REAL*8 TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL*8 TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+C
+C* Used Data Block:
+      REAL*8 TINTP(11)
+      SAVE TINTP
+c$OMP THREADPRIVATE(TINTP)
+      REAL*8 GA(11,16,3), GB(11,16,3)
+      SAVE GA, GB
+c$OMP THREADPRIVATE(GA, GB)
+      REAL*8 XP(6,6)
+      SAVE XP
+c$OMP THREADPRIVATE(XP)
+c
+      DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+     S             262.5, 275., 287.5, 300., 312.5 /
+C-----------------------------------------------------------------------
+C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+C
+C
+C
+C
+C-- R.D. -- G = - 0.2 SLA
+C
+C
+C----- INTERVAL = 1 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+      DATA (GB( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+      DATA (GA( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+      DATA (GB( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+      DATA (GB( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+      DATA (GA( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+      DATA (GB( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+      DATA (GB( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+      DATA (GA( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+      DATA (GB( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+      DATA (GB( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+      DATA (GA( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+      DATA (GB( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+      DATA (GB( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+      DATA (GA( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+      DATA (GB( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+      DATA (GB( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+      DATA (GA( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+      DATA (GB( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+      DATA (GB( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+      DATA (GA( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+      DATA (GB( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+      DATA (GB( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+      DATA (GA( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+      DATA (GB( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+      DATA (GB( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+      DATA (GA( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+      DATA (GB( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+      DATA (GB(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+      DATA (GA(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+      DATA (GB(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+      DATA (GB(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+      DATA (GA(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+      DATA (GB(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+C
+C
+C
+C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+C
+C
+C
+C
+C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+C
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+      DATA (GB( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+      DATA (GA( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+      DATA (GB( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+      DATA (GB( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+      DATA (GA( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+      DATA (GB( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+      DATA (GB( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+      DATA (GA( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+      DATA (GB( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+      DATA (GB( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+      DATA (GA( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+      DATA (GB( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+      DATA (GB( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+      DATA (GA( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+      DATA (GB( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+      DATA (GB( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+      DATA (GA( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+      DATA (GB( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+      DATA (GB( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+      DATA (GA( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+      DATA (GB( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+      DATA (GB( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+      DATA (GA( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+      DATA (GB( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+      DATA (GB( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+      DATA (GA( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+      DATA (GB( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+      DATA (GB(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+      DATA (GA(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+      DATA (GB(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+      DATA (GB(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+      DATA (GA(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+      DATA (GB(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+C
+C
+C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C
+C--- G = 3.875E-03 ---------------
+C
+C----- INTERVAL = 3 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+      DATA (GB( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+      DATA (GA( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+      DATA (GB( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+      DATA (GB( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+      DATA (GA( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+      DATA (GB( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+      DATA (GB( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+      DATA (GA( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+      DATA (GB( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+      DATA (GB( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+      DATA (GA( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+      DATA (GB( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+      DATA (GB( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+      DATA (GA( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+      DATA (GB( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+      DATA (GB( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+      DATA (GA( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+      DATA (GB( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+      DATA (GB( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+      DATA (GA( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+      DATA (GB( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+      DATA (GB( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+      DATA (GA( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+      DATA (GB( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+      DATA (GB( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+      DATA (GA( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+      DATA (GB( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+      DATA (GB(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+      DATA (GA(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+      DATA (GB(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+      DATA (GB(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+      DATA (GA(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+      DATA (GB(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+C
+C
+C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+C
+C-- G = 3.6E-03
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+      DATA (GB( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+      DATA (GA( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+      DATA (GB( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+      DATA (GB( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+      DATA (GA( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+      DATA (GB( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+      DATA (GB( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+      DATA (GA( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+      DATA (GB( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+      DATA (GB( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+      DATA (GA( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+      DATA (GB( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+      DATA (GB( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+      DATA (GA( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+      DATA (GB( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+      DATA (GB( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+      DATA (GA( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+      DATA (GB( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+      DATA (GB( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+      DATA (GA( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+      DATA (GB( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+      DATA (GB( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+      DATA (GA( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+      DATA (GB( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+      DATA (GB( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+      DATA (GA( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+      DATA (GB( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+      DATA (GB(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+      DATA (GA(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+      DATA (GB(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+      DATA (GB(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+      DATA (GA(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+      DATA (GB(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+C
+C
+C
+C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+C
+C-- WATER VAPOR --- 350 - 500 CM-1
+C
+C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+C
+C----- INTERVAL = 5 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+      DATA (GB( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+      DATA (GA( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+      DATA (GB( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+      DATA (GB( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+      DATA (GA( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+      DATA (GB( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+      DATA (GB( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+      DATA (GA( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+      DATA (GB( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+      DATA (GB( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+      DATA (GA( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+      DATA (GB( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+      DATA (GB( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+      DATA (GA( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+      DATA (GB( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+      DATA (GB( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+      DATA (GA( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+      DATA (GB( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+      DATA (GB( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+      DATA (GA( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+      DATA (GB( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+      DATA (GB( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+      DATA (GA( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+      DATA (GB( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+      DATA (GB( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+      DATA (GA( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+      DATA (GB( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+      DATA (GB(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+      DATA (GA(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+      DATA (GB(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+      DATA (GB(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+      DATA (GA(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+      DATA (GB(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+C
+C
+C
+C
+C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+C--- G = 0.0
+C
+C
+C----- INTERVAL = 6 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+      DATA (GB( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+      DATA (GA( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+      DATA (GB( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+      DATA (GB( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+      DATA (GA( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+      DATA (GB( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+      DATA (GB( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+      DATA (GA( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+      DATA (GB( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+      DATA (GB( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+      DATA (GA( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+      DATA (GB( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+      DATA (GB( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+      DATA (GA( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+      DATA (GB( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+      DATA (GB( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+      DATA (GA( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+      DATA (GB( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+      DATA (GB( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+      DATA (GA( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+      DATA (GB( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+      DATA (GB( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+      DATA (GA( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+      DATA (GB( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+      DATA (GB( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+      DATA (GA( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+      DATA (GB( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+      DATA (GB(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+      DATA (GA(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+      DATA (GB(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+      DATA (GB(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+      DATA (GA(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+      DATA (GB(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C-- END WATER VAPOR
+C
+C
+C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+C
+C
+C
+C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+      DATA (GB( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+      DATA (GA( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+      DATA (GB( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+      DATA (GB( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+      DATA (GA( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+      DATA (GB( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+      DATA (GB( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+      DATA (GA( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+      DATA (GB( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+      DATA (GB( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+      DATA (GA( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+      DATA (GB( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+      DATA (GB( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+      DATA (GA( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+      DATA (GB( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+      DATA (GB( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+      DATA (GA( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+      DATA (GB( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+      DATA (GB( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+      DATA (GA( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+      DATA (GB( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+      DATA (GB( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+      DATA (GA( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+      DATA (GB( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+      DATA (GB( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+      DATA (GA( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+      DATA (GB( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+      DATA (GB(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+      DATA (GA(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+      DATA (GB(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+      DATA (GB(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+      DATA (GA(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+      DATA (GB(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C-- G = 0.0
+C
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+      DATA (GB( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+      DATA (GA( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+      DATA (GB( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+      DATA (GB( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+      DATA (GA( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+      DATA (GB( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+      DATA (GB( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+      DATA (GA( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+      DATA (GB( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+      DATA (GB( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+      DATA (GA( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+      DATA (GB( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+      DATA (GB( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+      DATA (GA( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+      DATA (GB( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+      DATA (GB( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+      DATA (GA( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+      DATA (GB( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+      DATA (GB( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+      DATA (GA( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+      DATA (GB( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+      DATA (GB( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+      DATA (GA( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+      DATA (GB( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+      DATA (GB( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+      DATA (GA( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+      DATA (GB( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+      DATA (GB(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+      DATA (GA(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+      DATA (GB(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+      DATA (GB(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+      DATA (GA(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+      DATA (GB(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+
+C     ------------------------------------------------------------------
+      DATA (( XP(  J,K),J=1,6),       K=1,6) /
+     S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+     S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+     S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+     S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+     S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+     S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+     S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+     S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+     S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+     S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+     S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+     S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+C
+C
+C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+C                  ------------------------------
+C
+ 100  CONTINUE
+C
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+C
+      DO 141 JNU=1,Ninter
+C
+C
+C*         1.1   LEVELS FROM SURFACE TO KFLEV
+C                ----------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C
+C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+C                ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+C
+C
+C*         1.3   GRADIENTS IN SUB-LAYERS
+C                -----------------------
+C
+ 130  CONTINUE
+C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+C
+ 141  CONTINUE
+C
+C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+C                ---------------------------------------------
+C
+ 200  CONTINUE
+C
+C
+ 210  CONTINUE
+C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+C
+ 220  CONTINUE
+C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWV(KUAER,KTRAER, KLIM
+     R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+C           FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+C                      -  THE DISTANT LAYERS
+C                      -  THE BOUNDARY TERMS
+C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+C-----------------------------------------------------------------------
+C LOCAL VARIABLES:
+      REAL*8 ZADJD(KDLON,KFLEV+1)
+      REAL*8 ZADJU(KDLON,KFLEV+1)
+      REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
+      REAL*8 ZDISD(KDLON,KFLEV+1)
+      REAL*8 ZDISU(KDLON,KFLEV+1)
+C
+      INTEGER jk, jl
+C-----------------------------------------------------------------------
+C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C* CONTRIBUTION FROM ADJACENT LAYERS
+C
+      CALL LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+C* CONTRIBUTION FROM DISTANT LAYERS
+C
+      CALL LWVD(KUAER,KTRAER
+     R  , PABCU,ZDBDT,PGA,PGB
+     S  , PCNTRB,ZDISD,ZDISU)
+C
+C* EXCHANGE WITH THE BOUNDARIES
+C
+      CALL LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
+     R  , ZDISD,ZDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
+     R  , PDISD,PDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+C           INTEGRATION
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+C     ATMOSPHERE
+C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZBGND(KDLON)
+      REAL*8 ZFD(KDLON)
+      REAL*8  ZFN10(KDLON)
+      REAL*8 ZFU(KDLON)
+      REAL*8  ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8  ZUU(KDLON,NUA) 
+      REAL*8 ZCNSOL(KDLON)
+      REAL*8 ZCNTOP(KDLON)
+C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL*8 zctstr
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+C                  -----------------------------------
+C
+ 230  CONTINUE
+C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+C
+C
+      CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+C
+ 235  CONTINUE
+C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)
+     1   + PBTOP(JL,2)
+     2   + PBTOP(JL,3)
+     3   + PBTOP(JL,4)
+     4   + PBTOP(JL,5)
+     5   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+C
+C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+C                  ---------------------------------------
+C
+ 240  CONTINUE
+C
+C
+C*         2.4.1   INITIALIZATION
+C                  --------------
+C
+ 2410 CONTINUE
+C
+      JLIM = KFLEV
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+C
+C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+C                  -----------------------------
+C
+ 2420   CONTINUE
+C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+C
+C
+        CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =
+     1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
+     1       *(ZTT1(JL,1)           *ZTT1(JL,10)
+     1       - ZTT (JL,1)           *ZTT (JL,10))
+     2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
+     2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
+     2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
+     3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
+     3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
+     3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
+     4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
+     4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
+     4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
+     5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
+     5       *(ZTT1(JL,3)           *ZTT1(JL,14)
+     5       - ZTT (JL,3)           *ZTT (JL,14))
+     6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
+     6       *(ZTT1(JL,6)           *ZTT1(JL,15)
+     6       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+C
+C
+C*         2.5     EXCHANGE WITH LOWER LIMIT
+C                  -------------------------
+C
+ 250  CONTINUE
+C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
+     S               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)
+     1 +PBSUR(JL,2)
+     2 +PBSUR(JL,3)
+     3 +PBSUR(JL,4)
+     4 +PBSUR(JL,5)
+     5 +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+C
+C
+      CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+C
+C
+ 257  CONTINUE
+C
+C
+C
+C*         2.7     CLEAR-SKY FLUXES
+C                  ----------------
+C
+ 270  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWVD(KUAER,KTRAER
+     S  , PABCU,PDBDT
+     R  , PGA,PGB
+     S  , PCNTRB,PDISD,PDISU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL*8 PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL*8 zww, zdzxdg, zdzxmg
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+C                  ---------------------------------
+C
+ 220  CONTINUE
+C
+C
+C*         2.2.1   DISTANT AND ABOVE LAYERS
+C                  ------------------------
+C
+ 2210 CONTINUE
+C
+C
+C
+C*         2.2.2   FIRST UPPER LEVEL
+C                  -----------------
+C
+ 2220 CONTINUE
+C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+C
+      CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
+     2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+C
+C
+C
+C*         2.2.3   HIGHER UP
+C                  ---------
+C
+ 2230 CONTINUE
+C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+C
+C
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C
+C*         2.2.4   DISTANT AND BELOW LAYERS
+C                  ------------------------
+C
+ 2240 CONTINUE
+C
+C
+C
+C*         2.2.5   FIRST LOWER LEVEL
+C                  -----------------
+C
+ 2250 CONTINUE
+C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+C
+C
+      CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
+     2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+C
+C
+C
+C*         2.2.6   DOWN BELOW
+C                  ----------
+C
+ 2260 CONTINUE
+C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+C
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+C
+C
+ 227  CONTINUE
+ 228  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , PADJD,PADJU,PCNTRB,PDBDT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+C
+C* LOCAL ARRAYS:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8 ZUU(KDLON,NUA)
+C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL*8 zwtr
+c
+C* Data Block:
+c
+      REAL*8 WG1(2)
+      SAVE WG1
+c$OMP THREADPRIVATE(WG1)
+      DATA (WG1(jk),jk=1,2) /1.0, 1.0/
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+C
+C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+C                  ---------------------------------
+C
+ 210  CONTINUE
+C
+      DO 215 JK = 1 , KFLEV
+C
+C*         2.1.1   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+C
+C*         2.1.2   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+C
+ 213  CONTINUE
+C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+C
+ 215  CONTINUE
+C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+C
+      RETURN
+C
+      END
+      SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PUU(KDLON,NUA)
+      REAL*8 PTT(KDLON,NTRA)
+      REAL*8 PGA(KDLON,8,2)
+      REAL*8 PGB(KDLON,8,2)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL*8 zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL*8 zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+c     NEXOTIC=1
+c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER ja, jl
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL*8 zxch4, zych4, zsqh41, zodh41
+      REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL*8 zuu11, zuu12
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
+     S         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/radopt.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/radopt.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/radopt.h	(revision 984)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+      LOGICAL LEVOIGT
+      PARAMETER (LEVOIGT=.FALSE.)
+      INTEGER NOVLP
+      PARAMETER (NOVLP=1)
+      INTEGER KAER
+      PARAMETER (KAER=0)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ran0_vec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ran0_vec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ran0_vec.F	(revision 984)
@@ -0,0 +1,34 @@
+!
+! $Header$
+!
+      subroutine ran0_vec(npoints,idum,ran0)
+
+!     $Id$
+!     Platform independent random number generator from
+!     Numerical Recipies
+!     Mark Webb July 1999
+      
+      implicit none
+
+      integer j,npoints,idum(npoints),IA,IM,IQ,IR,k(npoints)
+      real ran0(npoints),AM
+
+      parameter (IA=16807, IM=2147483647, AM=1.0/IM, IQ=127773, IR=2836)
+      
+c     do j=1,npoints
+c       if (idum(j).eq.0) then
+c     	  write(6,*) 'idum=',idum
+c  write(6,*) 'ZERO seed not allowed'
+c  stop
+c       endif
+c     enddo
+
+      do j=1,npoints
+        k(j)=idum(j)/IQ
+        idum(j)=IA*(idum(j)-k(j)*IQ)-IR*k(j)
+        if (idum(j).lt.0) idum(j)=idum(j)+IM
+        ran0(j)=AM*idum(j)
+      enddo
+
+      end
+      
Index: LMDZ4/tags/LF_20080728/libf/phytherm/read_pstoke.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/read_pstoke.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/read_pstoke.F	(revision 984)
@@ -0,0 +1,486 @@
+!
+! $Header$
+!
+c
+c
+	subroutine read_pstoke(irec,
+     .   zrec,zklono,zklevo,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   fm_therm,en_therm,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+C******************************************************************************
+C  Frederic HOURDIN, Abderrahmane IDELKADI
+C Lecture des parametres physique stockes online necessaires pour
+C recalculer offline le transport de traceurs sur une grille 2x plus fine que 
+C celle online 
+C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+C******************************************************************************
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	
+	  integer klono,klevo,imo,jmo
+	  parameter (imo=iim/2,jmo=(jjm+1)/2)
+	  parameter(klono=(jmo-1)*imo+2,klevo=llm)
+	  REAL phisfi(klono)
+          REAL phisfi2(imo,jmo+1),airefi2(imo,jmo+1)
+
+          REAL mfu(klono,klevo), mfd(klono,klevo)
+          REAL en_u(klono,klevo), de_u(klono,klevo)
+          REAL en_d(klono,klevo), de_d(klono,klevo)
+          REAL coefh(klono,klevo)
+           REAL fm_therm(klono,klevo),en_therm(klono,klevo)
+
+          REAL mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo)
+          REAL en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo)
+          REAL en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo)
+          REAL coefh2(imo,jmo+1,klevo)
+           REAL fm_therm2(imo,jmo+1,klevo)
+           REAL en_therm2(imo,jmo+1,klevo)
+
+          REAL pl(klevo)
+          integer irec
+          integer xid,yid,zid,tid
+          real zrec,zklono,zklevo,zim,zjm
+          integer ncrec,ncklono,ncklevo,ncim,ncjm
+
+          real airefi(klono)
+          character*20 namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def klono
+c dim de phis??
+	  
+	 
+          REAL frac_impa(klono,klevo), frac_nucl(klono,klevo)
+          REAL frac_impa2(imo,jmo+1,klevo), 
+     .     frac_nucl2(imo,jmo+1,klevo)
+          REAL pyu1(klono), pyv1(klono)
+          REAL pyu12(imo,jmo+1), pyv12(imo,jmo+1)
+          REAL ftsol(klono,nbsrf)
+          REAL psrf(klono,nbsrf) 
+	  REAL ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono)
+          REAL psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono)
+          REAL ftsol12(imo,jmo+1),ftsol22(imo,jmo+1),
+     .     ftsol32(imo,jmo+1),
+     .     ftsol42(imo,jmo+1)
+          REAL psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1),
+     .     psrf42(imo,jmo+1)
+		REAL t(klono,klevo)
+		REAL t2(imo,jmo+1,klevo)	
+	  integer ncidp
+          save ncidp
+		integer varidt
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+          integer varidend,varidded,varidch,varidfi,varidfn
+           integer varidfmth,varidenth
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+          save varidend,varidded,varidch,varidfi,varidfn
+           save varidfmth,varidenth
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+		save varidt
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+c A FAIRE: Es-il necessaire de stocke t?
+	        varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+	
+c abder (pour thermiques)
+             varidfmth=NCVID(ncidp,'fm_th',rcode)
+             print*,'ncidp,varidfmth',ncidp,varidfmth
+
+             varidenth=NCVID(ncidp,'en_th',rcode)
+             print*,'ncidp,varidenth',ncidp,varidenth
+
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,ncklevo)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zklevo=ncklevo
+            zim=ncim
+            zjm=ncjm
+	
+	    zklono=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : zklevo = ', zklevo
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : zklono = ', zklono
+
+c niveaux de pression
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,zklevo,pl)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl)
+#endif
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi)
+
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+       call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=zklevo
+      count(4)=1
+
+
+C *** Lessivage******************************************************
+c frac_impa 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa)
+
+c frac_nucl 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl)
+
+C*** Temperature ******************************************************
+c abder t
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t)
+
+C*** Flux pour le calcul de la convection TIEDTK ***********************
+c mfu
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d)
+
+C **** Coeffecient du mellange turbulent**********************************
+c coefh 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+       call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh)
+
+C*** Flux ascendant et entrant pour les Thermiques************************
+cabder thermiques
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,count,fm_therm2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfmth,start,count,fm_therm2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,fm_therm2,fm_therm)
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,count,en_therm2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenth,start,count,en_therm2)
+#endif
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_therm2,en_therm)
+
+C*** Vitesses aux sol ******************************************************
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+c pyu1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1)
+
+c pyv1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1)
+
+C*** Temperature au sol ********************************************
+c ftsol1
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1)
+
+c ftsol2
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2)
+
+c ftsol3
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4)
+
+C*** Nature du sol **************************************************
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4)
+	
+          do i = 1,klono
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/read_pstoke0.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/read_pstoke0.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/read_pstoke0.F	(revision 984)
@@ -0,0 +1,510 @@
+!
+! $Header$
+!
+c
+c
+	subroutine read_pstoke0(irec,
+     .   zrec,zkon,zkev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   fm_therm,en_therm,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+C******************************************************************************
+C  Frederic HOURDIN, Abderrahmane IDELKADI
+C Lecture des parametres physique stockes online necessaires pour
+C recalculer offline le transport des traceurs sur la meme grille que online
+C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+C******************************************************************************
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	  
+	  integer kon,kev,zkon,zkev
+	  parameter(kon=iim*(jjm-1)+2,kev=llm)
+	  REAL phisfi(kon)
+          REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
+
+          REAL mfu(kon,kev), mfd(kon,kev)
+          REAL en_u(kon,kev), de_u(kon,kev)
+          REAL en_d(kon,kev), de_d(kon,kev)
+          REAL coefh(kon,kev)
+
+c abd 25 11 02
+c Thermiques
+	 REAL fm_therm(kon,kev),en_therm(kon,kev)
+		REAL t(kon,kev)
+
+          REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
+          REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
+          REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
+          REAL coefh2(iim,jjm+1,kev)
+		REAL t2(iim,jjm+1,kev)
+c Thermiques
+	 REAL fm_therm2(iim,jjm+1,kev)
+         REAL en_therm2(iim,jjm+1,kev)       
+
+          REAL pl(kev)
+          integer irec
+          integer xid,yid,zid,tid
+          integer zrec,zim,zjm
+          integer ncrec,nckon,nckev,ncim,ncjm
+
+          real airefi(kon)
+          character*20 namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def kon
+c dim de phis??
+
+          REAL frac_impa(kon,kev), frac_nucl(kon,kev)
+          REAL frac_impa2(iim,jjm+1,kev), 
+     .     frac_nucl2(iim,jjm+1,kev)
+          REAL pyu1(kon), pyv1(kon)
+          REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1)
+          REAL ftsol(kon,nbsrf)
+          REAL psrf(kon,nbsrf) 
+	  REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
+          REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
+          REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
+     .     ftsol32(iim,jjm+1),
+     .     ftsol42(iim,jjm+1)
+          REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
+     .     psrf42(iim,jjm+1)
+	
+	  integer ncidp
+          save ncidp
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+		integer varidt
+          integer varidend,varidded,varidch,varidfi,varidfn
+c therm
+	  integer varidfmth,varidenth
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+		save varidt
+          save varidend,varidded,varidch,varidfi,varidfn
+c therm
+	   save varidfmth,varidenth
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+                varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+
+c Thermiques
+            varidfmth=NCVID(ncidp,'fm_th',rcode)
+            print*,'ncidp,varidfmth',ncidp,varidfmth
+
+            varidenth=NCVID(ncidp,'en_th',rcode)
+            print*,'ncidp,varidenth',ncidp,varidenth
+	
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,nckev)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zkev=nckev
+            zim=ncim
+            zjm=ncjm
+	
+	    zkon=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : kev = ', zkev
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : kon = ', zkon
+
+c niveaux de pression
+
+            status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c 
+C**** Geopotentiel au sol ***************************************
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
+
+C**** Aires des mails aux sol ************************************
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=kev
+      count(4)=1
+
+C**** Temperature ********************************************
+cA FAIRE : Es-ce necessaire ?
+
+c abder t
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
+
+C**** Flux pour la convection (Tiedtk) ********************************************
+c mfu
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
+
+C**** Coefficient de mellange turbulent *******************************************
+c coefh 
+	print*,'LECTURE de coefh a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
+c      call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ   ')
+c      call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ   ')
+
+C**** Flux ascendants et entrant dans le thermique **********************************
+cThermiques
+       print*,'LECTURE de fm_therm a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,
+     .                         count,fm_therm2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidfmth,start,
+     .                         count,fm_therm2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm)
+       print*,'LECTURE de en_therm a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,
+     .                          count,en_therm2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidenth,start,
+     .                          count,en_therm2)
+#endif
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm)
+
+C**** Coefficients de lessivage *******************************************
+c frac_impa
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
+
+c frac_nucl
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
+
+C**** Vents aux sol ********************************************
+
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+
+c pyu1
+	print*,'LECTURE de yu1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
+
+c pyv1
+        print*,'LECTURE de yv1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+        status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
+
+C**** Temerature au sol ********************************************
+c ftsol1
+        print*,'LECTURE de ftsol1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
+
+c ftsol2
+        print*,'LECTURE de ftsol2 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
+
+c ftsol3
+	 print*,'LECTURE de ftsol3 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
+
+C**** Nature sol ********************************************
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
+	
+          do i = 1,kon
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+c test abderr
+c	print*,'Dans read_pstoke psrf3 =',psrf3(i),i
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/readsulfate.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/readsulfate.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/readsulfate.F	(revision 984)
@@ -0,0 +1,640 @@
+!
+! $Header$
+!
+      SUBROUTINE readsulfate (r_day, first, sulfate_p)
+      USE dimphy, ONLY : klev
+      USE mod_grid_phy_lmdz, klon=>klon_glo
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+      
+c Content: 
+c --------
+c This routine reads in monthly mean values of sulfate aerosols and 
+c returns a linearly interpolated dayly-mean field.      
+c 
+c
+c Author:
+c -------
+c Johannes Quaas (quaas@lmd.jussieu.fr) 
+c 26/04/01
+c
+c Modifications:
+c --------------
+c 21/06/01: Make integrations of more than one year possible ;-)     
+c           ATTENTION!! runs are supposed to start with Jan, 1. 1930
+c                       (rday=1)      
+c
+c 27/06/01: Correction: The model always has 360 days per year!
+c 27/06/01: SO4 concentration rather than mixing ratio      
+c 27/06/01: 10yr-mean-values to interpolate     
+c 20/08/01: Correct the error through integer-values in interpolations      
+c 21/08/01: Introduce flag to read in just one decade
+c      
+c Include-files:
+c --------------     
+#include "YOMCST.h"
+#include "chem.h"      
+#include "dimensions.h"      
+cym#include "dimphy.h"      
+#include "temps.h"      
+c 
+c Input:
+c ------
+      REAL  r_day                   ! Day of integration
+      LOGICAL first                 ! First timestep 
+                                    ! (and therefore initialization necessary)
+c      
+c Output:      
+c -------     
+      REAL  sulfate_p(klon_omp,klev)
+      REAL  sulfate (klon, klev)  ! Mass of sulfate (monthly mean data, 
+                                  !  from file) [ug SO4/m3]
+c      
+c Local Variables:
+c ----------------      
+      INTEGER i, ig, k, it
+      INTEGER j, iday, ny, iyr, iyr1, iyr2
+      parameter (ny=jjm+1)
+      
+CJLD      INTEGER idec1, idec2 ! The two decadal data read ini
+      CHARACTER*4 cyear
+      
+      INTEGER im, day1, day2, im2
+      REAL so4_1(iim, jjm+1, klev, 12)
+      REAL so4_2(iim, jjm+1, klev, 12)   ! The sulfate distributions
+      
+      REAL, allocatable,save :: so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: so4_out(:, :)
+c$OMP THREADPRIVATE(so4,so4_out)
+      
+      LOGICAL lnewday 
+      LOGICAL lonlyone
+      PARAMETER (lonlyone=.FALSE.)
+      logical,save :: first2=.true.
+c$OMP THREADPRIVATE(first2)
+
+c$OMP MASTER
+      if (first2) then
+     
+        allocate( so4(klon, klev, 12) )
+        allocate( so4_out(klon, klev))
+        first2=.false.
+	
+      endif
+
+      if (is_mpi_root) then
+            
+      iday = INT(r_day) 
+      
+      ! Get the year of the run
+      iyr  = iday/360
+      
+      ! Get the day of the actual year:
+      iday = iday-iyr*360
+      
+      ! 0.02 is about 0.5/24, namly less than half an hour
+      lnewday = (r_day-FLOAT(iday).LT.0.02)
+      
+! ---------------------------------------------
+! All has to be done only, if a new day begins!       
+! ---------------------------------------------
+
+      IF (lnewday.OR.first) THEN
+         
+      im = iday/30 +1 ! the actual month
+      ! annee_ref is the initial year (defined in temps.h)
+      iyr = iyr + annee_ref
+      
+      ! Do I have to read new data? (Is this the first day of a year?)
+      IF (first.OR.iday.EQ.1.) THEN 
+      ! Initialize values
+      DO it=1,12
+      DO k=1,klev
+         DO i=1,klon
+            so4(i,k,it)=0.
+         ENDDO
+      ENDDO
+      ENDDO
+
+
+      IF (iyr .lt. 1850) THEN
+         cyear='.nat'
+         WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+         CALL getso4fromfile(cyear, so4_1)
+      ELSE IF (iyr .ge. 2100) THEN
+         cyear='2100'
+         WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+         CALL getso4fromfile(cyear, so4_1)
+      ELSE
+
+      	! Read in data:
+      ! a) from actual 10-yr-period
+
+      IF (iyr.LT.1900) THEN
+         iyr1 = 1850
+         iyr2 = 1900
+      ELSE IF (iyr.ge.1900.and.iyr.lt.1920) THEN
+         iyr1 = 1900
+         iyr2 = 1920
+      ELSE 
+         iyr1 = INT(iyr/10)*10
+         iyr2 = INT(1+iyr/10)*10
+      ENDIF
+      WRITE(cyear,'(I4)') iyr1
+      WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+      CALL getso4fromfile(cyear, so4_1)
+
+      
+      ! If to read two decades:
+      IF (.NOT.lonlyone) THEN
+         
+      ! b) from the next following one
+      WRITE(cyear,'(I4)') iyr2
+      WRITE(*,*) 'getso4  iyr=', iyr,'   ',cyear
+      CALL getso4fromfile(cyear, so4_2)
+
+      ENDIF
+ 
+      ! Interpolate linarily to the actual year:
+      DO it=1,12
+         DO k=1,klev
+            DO j=1,jjm
+               DO i=1,iim
+                  so4_1(i,j,k,it)=so4_1(i,j,k,it)
+     .                 - FLOAT(iyr-iyr1)/FLOAT(iyr2-iyr1)
+     .                 * (so4_1(i,j,k,it) - so4_2(i,j,k,it))
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDDO                           
+      
+      ENDIF !lonlyone
+      
+      ! Transform the horizontal 2D-field into the physics-field
+      ! (Also the levels and the latitudes have to be inversed)
+      
+      DO it=1,12
+      DO k=1, klev         
+         ! a) at the poles, use the zonal mean:
+         DO i=1,iim
+            ! North pole
+            so4(1,k,it)=so4(1,k,it)+so4_1(i,jjm+1,klev+1-k,it)
+            ! South pole
+            so4(klon,k,it)=so4(klon,k,it)+so4_1(i,1,klev+1-k,it)
+         ENDDO
+         so4(1,k,it)=so4(1,k,it)/FLOAT(iim)
+         so4(klon,k,it)=so4(klon,k,it)/FLOAT(iim)
+      
+         ! b) the values between the poles:
+         ig=1
+         DO j=2,jjm
+            DO i=1,iim
+               ig=ig+1
+               if (ig.gt.klon) write (*,*) 'shit'
+               so4(ig,k,it) = so4_1(i,jjm+1+1-j,klev+1-k,it)
+            ENDDO
+         ENDDO
+         IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)'
+      ENDDO ! Loop over k (vertical)
+      ENDDO ! Loop over it (months)
+               
+
+      ENDIF ! Had to read new data?
+      
+      
+      ! Interpolate to actual day:
+      IF (iday.LT.im*30-15) THEN         
+         ! in the first half of the month use month before and actual month
+         im2=im-1
+         day2 = im2*30-15
+         day1 = im2*30+15
+         IF (im2.LE.0) THEN 
+            ! the month is january, thus the month before december
+            im2=12
+         ENDIF
+         DO k=1,klev
+            DO i=1,klon
+               sulfate(i,k) = so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (so4(i,k,im2) - so4(i,k,im))
+               IF (sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (so4(i,k,im2) - so4(i,k,im).LT.0.)
+     . write(*,*) 'so4(i,k,im2) - so4(i,k,im)',
+     . so4(i,k,im2) - so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ELSE 
+         ! the second half of the month
+         im2=im+1
+         IF (im2.GT.12) THEN
+            ! the month is december, the following thus january
+            im2=1
+         ENDIF
+         day2 = im*30-15
+         day1 = im*30+15
+         DO k=1,klev
+            DO i=1,klon
+               sulfate(i,k) = so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (so4(i,k,im2) - so4(i,k,im))
+               IF (sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (so4(i,k,im2) - so4(i,k,im).LT.0.)
+     . write(*,*) 'so4(i,k,im2) - so4(i,k,im)',
+     . so4(i,k,im2) - so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+
+      
+CJLD      ! The sulfate concentration [molec cm-3] is read in. 
+CJLD      ! Convert it into mass [ug SO4/m3]
+CJLD      ! masse_so4 in [g/mol], n_avogadro in [molec/mol]
+      ! The sulfate mass [ug SO4/m3] is read in. 
+      DO k=1,klev
+         DO i=1,klon
+CJLD            sulfate(i,k) = sulfate(i,k)*masse_so4
+CJLD     .           /n_avogadro*1.e+12
+            so4_out(i,k) = sulfate(i,k)
+            IF (so4_out(i,k).LT.0) 
+     .          stop 'WAS SOLL DER SCHEISS ? '
+         ENDDO
+      ENDDO
+      ELSE ! if no new day, use old data:
+      DO k=1,klev
+         DO i=1,klon
+            sulfate(i,k) = so4_out(i,k)
+            IF (so4_out(i,k).LT.0) 
+     .          stop 'WAS SOLL DER SCHEISS ? '
+         ENDDO
+      ENDDO
+         
+
+      ENDIF ! Did I have to do anything (was it a new day?)
+
+      endif   ! phy_rank==0
+      
+c$OMP END MASTER
+      call Scatter(sulfate,sulfate_p)            
+
+      RETURN
+      END
+
+      
+      
+      
+      
+c-----------------------------------------------------------------------------
+c Read in /calculate pre-industrial values of sulfate      
+c-----------------------------------------------------------------------------
+      
+      SUBROUTINE readsulfate_preind (r_day, first, pi_sulfate_p)
+      USE dimphy, ONLY : klev
+      USE mod_grid_phy_lmdz, klon=>klon_glo
+      USE mod_phys_lmdz_para
+      IMPLICIT none
+      
+c Content: 
+c --------
+c This routine reads in monthly mean values of sulfate aerosols and 
+c returns a linearly interpolated dayly-mean field.      
+c 
+c It does so for the preindustriel values of the sulfate, to a large part
+c analogous to the routine readsulfate above.      
+c
+c Only Pb: Variables must be saved and don t have to be overwritten!
+c      
+c Author:
+c -------
+c Johannes Quaas (quaas@lmd.jussieu.fr) 
+c 26/06/01
+c
+c Modifications:
+c --------------
+c see above 
+c      
+c Include-files:
+c --------------     
+#include "YOMCST.h"
+#include "chem.h"      
+#include "dimensions.h"      
+#include "temps.h"      
+c 
+c Input:
+c ------
+      REAL  r_day                   ! Day of integration
+      LOGICAL first                 ! First timestep 
+                                    ! (and therefore initialization necessary)
+c      
+c Output:      
+c -------     
+      REAL  pi_sulfate_p (klon_omp, klev)  
+                                 
+      REAL  pi_sulfate (klon, klev)  ! Number conc. sulfate (monthly mean data, 
+                                  !  from fil
+c      
+c Local Variables:
+c ----------------      
+      INTEGER i, ig, k, it
+      INTEGER j, iday, ny, iyr
+      parameter (ny=jjm+1)
+      
+      INTEGER im, day1, day2, im2
+      REAL pi_so4_1(iim, jjm+1, klev, 12)
+
+      REAL, allocatable,save :: pi_so4(:, :, :)  ! SO4 in right dimension
+      REAL, allocatable,save :: pi_so4_out(:, :)
+c$OMP THREADPRIVATE(pi_so4,pi_so4_out)            
+      
+      CHARACTER*4 cyear
+      LOGICAL lnewday
+      logical,save :: first2=.true.
+c$OMP THREADPRIVATE(first2)
+
+c$OMP MASTER
+      if (first2) then
+     
+        allocate( pi_so4(klon, klev, 12) )
+        allocate( pi_so4_out(klon, klev))
+        first2=.false.
+	
+      endif
+
+      if (is_mpi_root) then
+    
+      
+
+      iday = INT(r_day) 
+      
+      ! Get the year of the run
+      iyr  = iday/360
+      
+      ! Get the day of the actual year:
+      iday = iday-iyr*360
+      
+      ! 0.02 is about 0.5/24, namly less than half an hour
+      lnewday = (r_day-FLOAT(iday).LT.0.02)
+      
+! ---------------------------------------------
+! All has to be done only, if a new day begins!       
+! ---------------------------------------------
+
+      IF (lnewday.OR.first) THEN
+         
+      im = iday/30 +1 ! the actual month
+      
+      ! annee_ref is the initial year (defined in temps.h)
+      iyr = iyr + annee_ref      
+      
+      
+      IF (first) THEN
+         cyear='.nat'
+         CALL getso4fromfile(cyear,pi_so4_1)
+
+               ! Transform the horizontal 2D-field into the physics-field
+               ! (Also the levels and the latitudes have to be inversed)
+
+         ! Initialize field
+         DO it=1,12
+            DO k=1,klev
+               DO i=1,klon
+                  pi_so4(i,k,it)=0.
+               ENDDO
+            ENDDO
+         ENDDO
+         
+         write (*,*) 'preind: finished reading', FLOAT(iim)
+      DO it=1,12
+      DO k=1, klev         
+         ! a) at the poles, use the zonal mean:
+         DO i=1,iim
+            ! North pole
+            pi_so4(1,k,it)=pi_so4(1,k,it)+pi_so4_1(i,jjm+1,klev+1-k,it)
+            ! South pole
+           pi_so4(klon,k,it)=pi_so4(klon,k,it)+pi_so4_1(i,1,klev+1-k,it)
+         ENDDO
+         pi_so4(1,k,it)=pi_so4(1,k,it)/FLOAT(iim)
+         pi_so4(klon,k,it)=pi_so4(klon,k,it)/FLOAT(iim)
+      
+         ! b) the values between the poles:
+         ig=1
+         DO j=2,jjm
+            DO i=1,iim
+               ig=ig+1
+               if (ig.gt.klon) write (*,*) 'shit'
+               pi_so4(ig,k,it) = pi_so4_1(i,jjm+1+1-j,klev+1-k,it)
+            ENDDO
+         ENDDO
+         IF (ig.NE.klon-1) STOP 'Error in readsulfate (var conversion)'
+      ENDDO ! Loop over k (vertical)
+      ENDDO ! Loop over it (months)
+
+      ENDIF                     ! Had to read new data?
+      
+      
+      ! Interpolate to actual day:
+      IF (iday.LT.im*30-15) THEN         
+         ! in the first half of the month use month before and actual month
+         im2=im-1
+         day1 = im2*30+15
+         day2 = im2*30-15
+         IF (im2.LE.0) THEN 
+            ! the month is january, thus the month before december
+            im2=12
+         ENDIF
+         DO k=1,klev
+            DO i=1,klon
+               pi_sulfate(i,k) = pi_so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (pi_so4(i,k,im2) - pi_so4(i,k,im))
+               IF (pi_sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.)
+     . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)',
+     . pi_so4(i,k,im2) - pi_so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'pi_sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ELSE 
+         ! the second half of the month
+         im2=im+1
+         day1 = im*30+15
+         IF (im2.GT.12) THEN
+            ! the month is december, the following thus january
+            im2=1
+         ENDIF
+         day2 = im*30-15
+         
+         DO k=1,klev
+            DO i=1,klon
+               pi_sulfate(i,k) = pi_so4(i,k,im2)  
+     .              - FLOAT(iday-day2)/FLOAT(day1-day2)
+     .              * (pi_so4(i,k,im2) - pi_so4(i,k,im))
+               IF (pi_sulfate(i,k).LT.0.) THEN
+                  IF (iday-day2.LT.0.) write(*,*) 'iday-day2',iday-day2
+                  IF (pi_so4(i,k,im2) - pi_so4(i,k,im).LT.0.)
+     . write(*,*) 'pi_so4(i,k,im2) - pi_so4(i,k,im)',
+     . pi_so4(i,k,im2) - pi_so4(i,k,im)
+                  IF (day1-day2.LT.0.) write(*,*) 'day1-day2',day1-day2
+                  stop 'pi_sulfate'
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+
+      
+CJLD      ! The sulfate concentration [molec cm-3] is read in. 
+CJLD      ! Convert it into mass [ug SO4/m3]
+CJLD      ! masse_so4 in [g/mol], n_avogadro in [molec/mol]
+      DO k=1,klev
+         DO i=1,klon
+CJLD            pi_sulfate(i,k) = pi_sulfate(i,k)*masse_so4
+CJLD     .           /n_avogadro*1.e+12
+            pi_so4_out(i,k) = pi_sulfate(i,k)
+         ENDDO
+      ENDDO
+      
+      ELSE ! If no new day, use old data:
+      DO k=1,klev
+         DO i=1,klon
+            pi_sulfate(i,k) = pi_so4_out(i,k)            
+         ENDDO
+      ENDDO
+         
+
+      ENDIF ! Was this the beginning of a new day?
+
+      endif   ! is_mpi_root==0
+      
+c$OMP END MASTER
+      call Scatter(pi_sulfate,pi_sulfate_p)            
+
+      RETURN
+      END
+
+      
+      
+      
+      
+      
+      
+      
+      
+      
+c-----------------------------------------------------------------------------
+c Routine for reading SO4 data from files
+c-----------------------------------------------------------------------------
+            
+
+      SUBROUTINE getso4fromfile (cyr, so4)
+#include "netcdf.inc"
+#include "dimensions.h"      
+#include "dimphy.h"
+      CHARACTER*15 fname
+      CHARACTER*4 cyr
+      
+      CHARACTER*6 cvar
+      INTEGER START(3), COUNT(3)
+      INTEGER  STATUS, NCID, VARID
+      INTEGER imth, i, j, k, ny
+      PARAMETER (ny=jjm+1)
+      
+            
+      REAL so4mth(iim, ny, klev)
+      REAL so4(iim, ny, klev, 12)
+
+ 
+      fname = 'so4.run'//cyr//'.cdf'
+
+      write (*,*) 'reading ', fname
+      STATUS = NF_OPEN (fname, NF_NOWRITE, NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in open ',status
+            
+      DO imth=1, 12
+         IF (imth.eq.1) THEN
+            cvar='SO4JAN'
+         ELSEIF (imth.eq.2) THEN
+            cvar='SO4FEB'
+         ELSEIF (imth.eq.3) THEN
+            cvar='SO4MAR'
+         ELSEIF (imth.eq.4) THEN
+            cvar='SO4APR'
+         ELSEIF (imth.eq.5) THEN
+            cvar='SO4MAY'
+         ELSEIF (imth.eq.6) THEN
+            cvar='SO4JUN'
+         ELSEIF (imth.eq.7) THEN
+            cvar='SO4JUL'
+         ELSEIF (imth.eq.8) THEN
+            cvar='SO4AUG'
+         ELSEIF (imth.eq.9) THEN
+            cvar='SO4SEP'
+         ELSEIF (imth.eq.10) THEN
+            cvar='SO4OCT'
+         ELSEIF (imth.eq.11) THEN
+            cvar='SO4NOV'
+         ELSEIF (imth.eq.12) THEN
+            cvar='SO4DEC'
+         ENDIF
+         start(1)=1
+         start(2)=1
+         start(3)=1
+         count(1)=iim
+         count(2)=ny
+         count(3)=klev
+c         write(*,*) 'here i am'
+         STATUS = NF_INQ_VARID (NCID, cvar, VARID)
+         write (*,*) ncid,imth,cvar, varid
+
+         IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read ',status      
+
+#ifdef NC_DOUBLE
+         status = NF_GET_VARA_DOUBLE(NCID, VARID, START, COUNT, so4mth)
+#else
+         status = NF_GET_VARA_REAL(NCID, VARID, START, COUNT, so4mth)
+#endif
+         IF (STATUS .NE. NF_NOERR) write (*,*) 'err in read data',status
+         
+         DO k=1,klev
+            DO j=1,jjm+1
+               DO i=1,iim
+                  IF (so4mth(i,j,k).LT.0.) then
+                     write(*,*) 'this is shit'
+                     write(*,*) 'so4(',i,j,k,') =',so4mth(i,j,k)
+                  endif
+                  so4(i,j,k,imth)=so4mth(i,j,k)
+               ENDDO
+            ENDDO
+         ENDDO
+      ENDDO
+      
+      STATUS = NF_CLOSE(NCID)
+      IF (STATUS .NE. NF_NOERR) write (*,*) 'err in closing file',status
+
+
+      END ! subroutine getso4fromfile
+      
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/regdim.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/regdim.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/regdim.h	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      INTEGER i1_deb, i1_fin
+      INTEGER i2_deb, i2_fin
+ccc      PARAMETER (i1_deb=21, i1_fin=40)
+ccc      PARAMETER (i2_deb=41, i2_fin=44)
+cccc      PARAMETER (i1_deb=47, i1_fin=77)
+cccc      PARAMETER (i2_deb=78, i2_fin=79)
+      PARAMETER (i1_deb=16, i1_fin=30)
+      PARAMETER (i2_deb=31, i2_fin=33)
+c
+      INTEGER j_deb, j_fin
+ccc      PARAMETER (j_deb=29, j_fin=61)
+cccc      PARAMETER (j_deb=21, j_fin=51)
+      PARAMETER (j_deb=18, j_fin=39)
Index: LMDZ4/tags/LF_20080728/libf/phytherm/screenc.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/screenc.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/screenc.F90	(revision 984)
@@ -0,0 +1,84 @@
+!
+! $Header$
+!
+      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, rugos, psol, &
+                         ustar, testar, qstar, okri, ri1, &
+                         pref, delu, delte, delq)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
+!
+      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
+!-----------------------------------------------------------------------
+      include "YOMCST.h"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+      CALL coefcdrag (klon, knon, nsrf, zxli, &
+                    speed, temp, q_zref, gref, &
+                    psol, ts, qsurf, rugos, &
+                    okri, ri1, &
+                    cdram, cdrah, cdran, zri1, &
+                    pref)
+!
+      DO i = 1, knon
+        delu(i) = ustar(i)/sqrt(cdram(i))
+        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
+                   cdrah(i)
+        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
+                  cdrah(i)
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screenc
Index: LMDZ4/tags/LF_20080728/libf/phytherm/screenp.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/screenp.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/screenp.F90	(revision 984)
@@ -0,0 +1,108 @@
+!
+! $Header$
+!
+      SUBROUTINE screenp(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, lmon, &
+     &                   ustar, testar, qstar, zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! lmon----input-R- longueur de Monin-Obukov
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+        IF (lmon(i).GE.0.) THEN
+!
+! STABLE CASE
+!
+          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0) THEN
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 *(zref - rugos(i))/lmon(i)))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) + &
+                       min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+            delq(i) = (qstar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+          ELSE
+            delu(i)  = 0.1 * speed(i)
+            delte(i) = 0.1 * (tair(i) - ts(i) )
+            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ELSE  
+!
+! UNSTABLE CASE
+!
+          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
+            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
+            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) & 
+                      - 2.*log(0.5*(1. + xtmp)) &
+                      + 2.*log(0.5*(1. + xtmp0)) &
+                      - log(0.5*(1. + xtmp*xtmp)) &
+                      + log(0.5*(1. + xtmp0*xtmp0)) &
+                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+            delq(i)  = (qstar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+          ELSE
+            delu(i)  = 0.5 * speed(i)
+            delte(i) = 0.5 * (tair(i) - ts(i) )
+            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenp
Index: LMDZ4/tags/LF_20080728/libf/phytherm/soil.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/soil.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/soil.F	(revision 984)
@@ -0,0 +1,272 @@
+!
+! $Header$
+!
+      SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, ptsoil,
+     s          pcapcal, pfluxgrd)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  Frederic Hourdin     30/01/92
+c   -------
+c
+c   objet:  computation of : the soil temperature evolution
+c   ------                   the surfacic heat capacity "Capcal"
+c                            the surface conduction flux pcapcal
+c
+c
+c   Method: implicit time integration
+c   -------
+c   Consecutive ground temperatures are related by:
+c           T(k+1) = C(k) + D(k)*T(k)  (1)
+c   the coefficients C and D are computed at the t-dt time-step.
+c   Routine structure:
+c   1)new temperatures are computed  using (1)
+c   2)C and D coefficients are computed from the new temperature
+c     profile for the t+dt time-step
+c   3)the coefficients A and B are computed where the diffusive
+c     fluxes at the t+dt time-step is given by
+c            Fdiff = A + B Ts(t+dt)
+c     or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
+c            with F0 = A + B (Ts(t))
+c                 Capcal = B*dt
+c           
+c   Interface:
+c   ----------
+c
+c   Arguments:
+c   ----------
+c   ptimestep            physical timestep (s)
+c   indice               sub-surface index
+c   snow(klon,nbsrf)     snow
+c   ptsrf(klon)          surface temperature at time-step t (K)
+c   ptsoil(klon,nsoilmx) temperature inside the ground (K)
+c   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
+c   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
+c   
+c=======================================================================
+c   declarations:
+c   -------------
+
+cym#include "dimensions.h"
+#include "YOMCST.h"
+cym#include "dimphy.h"
+#include "dimsoil.h"
+#include "indicesol.h"
+
+c-----------------------------------------------------------------------
+c  arguments
+c  ---------
+
+      REAL ptimestep
+      INTEGER indice, knon
+      REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon)
+      REAL pcapcal(klon),pfluxgrd(klon)
+
+c-----------------------------------------------------------------------
+c  local arrays
+c  ------------
+
+      INTEGER ig,jk
+c@$$      REAL zdz2(nsoilmx),z1(klon)
+      REAL zdz2(nsoilmx),z1(klon,nbsrf)
+      REAL,SAVE :: min_period,dalph_soil
+c$OMP THREADPRIVATE( min_period,dalph_soil)     
+      REAL ztherm_i(klon)
+
+c   local saved variables:
+c   ----------------------
+      REAL dz1(nsoilmx),dz2(nsoilmx)
+c@$$          REAL zc(klon,nsoilmx),zd(klon,nsoilmx)
+cym      REAL zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf)
+      REAL,ALLOCATABLE,SAVE ::  zc(:,:,:),zd(:,:,:)
+c$OMP THREADPRIVATE(zc,zd)
+      REAL lambda
+cym      SAVE dz1,dz2,zc,zd,lambda
+      SAVE dz1,dz2,lambda
+c$OMP THREADPRIVATE(dz1,dz2,lambda)
+      LOGICAL firstcall, firstsurf(nbsrf)
+      SAVE firstcall, firstsurf
+c$OMP THREADPRIVATE(firstcall, firstsurf)
+      REAL isol,isno,iice
+      SAVE isol,isno,iice
+c$OMP THREADPRIVATE(isol,isno,iice)
+      DATA firstcall/.true./
+      DATA firstsurf/.TRUE.,.TRUE.,.TRUE.,.TRUE./
+
+      DATA isol,isno,iice/2000.,2000.,2000./
+      LOGICAL,SAVE :: First=.true.
+c$OMP THREADPRIVATE(First)
+c-----------------------------------------------------------------------
+c   Depthts:
+c   --------
+
+      REAL fz,rk,fz1,rk1,rk2
+      fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
+      pfluxgrd(:) = 0.
+c   calcul de l'inertie thermique a partir de la variable rnat.
+c   on initialise a iice meme au-dessus d'un point de mer au cas 
+c   ou le point de mer devienne point de glace au pas suivant
+c   on corrige si on a un point de terre avec ou sans glace
+c
+      IF (first) THEN
+        allocate(zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf))
+	first=.false.
+      ENDIF
+      
+      IF (indice.EQ.is_sic) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = iice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_lic) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = iice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_ter) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = isol
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_oce) THEN
+         DO ig = 1, knon
+            ztherm_i(ig)   = iice
+         ENDDO
+      ELSE
+         PRINT*, "valeur d indice non prevue", indice
+         CALL abort
+      ENDIF
+
+
+c@$$      IF (firstcall) THEN
+      IF (firstsurf(indice)) THEN 
+
+c-----------------------------------------------------------------------
+c   ground levels 
+c   grnd=z/l where l is the skin depth of the diurnal cycle:
+c   --------------------------------------------------------
+
+         min_period=1800. ! en secondes
+         dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
+c$OMP MASTER
+         IF (is_mpi_root) THEN
+         OPEN(99,file='soil.def',status='old',form='formatted',err=9999)
+         READ(99,*) min_period
+         READ(99,*) dalph_soil
+         PRINT*,'Discretization for the soil model'
+         PRINT*,'First level e-folding depth',min_period,
+     s   '   dalph',dalph_soil
+         CLOSE(99)
+9999     CONTINUE
+         ENDIF  ! is_mpi_root
+c$OMP END MASTER
+         CALL bcast(min_period)
+	 CALL bcast(dalph_soil)
+
+c   la premiere couche represente un dixieme de cycle diurne
+         fz1=sqrt(min_period/3.14)
+
+         DO jk=1,nsoilmx
+            rk1=jk
+            rk2=jk-1
+            dz2(jk)=fz(rk1)-fz(rk2)
+         ENDDO
+         DO jk=1,nsoilmx-1
+            rk1=jk+.5
+            rk2=jk-.5
+            dz1(jk)=1./(fz(rk1)-fz(rk2))
+         ENDDO
+         lambda=fz(.5)*dz1(1)
+         PRINT*,'full layers, intermediate layers (seconds)'
+         DO jk=1,nsoilmx
+            rk=jk
+            rk1=jk+.5
+            rk2=jk-.5
+            PRINT *,'fz=',
+     .               fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
+         ENDDO
+C PB
+         firstsurf(indice) = .FALSE. 
+c@$$         firstcall =.false.
+
+c   Initialisations:
+c   ----------------
+
+      ELSE   !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the soil temperatures using the Cgrd and Dgrd
+c  coefficient computed at the previous time-step:
+c  -----------------------------------------------
+
+c    surface temperature
+         DO ig=1,knon
+            ptsoil(ig,1)=(lambda*zc(ig,1,indice)+ptsrf(ig))/
+     s      (lambda*(1.-zd(ig,1,indice))+1.)
+         ENDDO
+
+c   other temperatures
+         DO jk=1,nsoilmx-1
+            DO ig=1,knon
+               ptsoil(ig,jk+1)=zc(ig,jk,indice)+zd(ig,jk,indice)
+     $            *ptsoil(ig,jk)
+            ENDDO
+         ENDDO
+
+      ENDIF !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the Cgrd and Dgrd coefficient for the next step:
+c   ---------------------------------------------------------------
+
+c@$$  PB ajout pour cas glace de mer
+      IF (indice .EQ. is_sic) THEN
+          DO ig = 1 , knon
+            ptsoil(ig,nsoilmx) = RTT - 1.8
+          END DO 
+      ENDIF 
+
+      DO jk=1,nsoilmx
+         zdz2(jk)=dz2(jk)/ptimestep
+      ENDDO
+
+      DO ig=1,knon
+         z1(ig,indice)=zdz2(nsoilmx)+dz1(nsoilmx-1)
+         zc(ig,nsoilmx-1,indice)=
+     $       zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig,indice)
+         zd(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1(ig,indice)
+      ENDDO
+
+      DO jk=nsoilmx-1,2,-1
+         DO ig=1,knon
+            z1(ig,indice)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk)
+     $         *(1.-zd(ig,jk,indice)))
+            zc(ig,jk-1,indice)=
+     s      (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk,indice))
+     $          *z1(ig,indice)
+            zd(ig,jk-1,indice)=dz1(jk-1)*z1(ig,indice)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   computation of the surface diffusive flux from ground and
+c   calorific capacity of the ground:
+c   ---------------------------------
+
+      DO ig=1,knon
+         pfluxgrd(ig)=ztherm_i(ig)*dz1(1)*
+     s   (zc(ig,1,indice)+(zd(ig,1,indice)-1.)*ptsoil(ig,1))
+         pcapcal(ig)=ztherm_i(ig)*
+     s   (dz2(1)+ptimestep*(1.-zd(ig,1,indice))*dz1(1))
+         z1(ig,indice)=lambda*(1.-zd(ig,1,indice))+1.
+         pcapcal(ig)=pcapcal(ig)/z1(ig,indice)
+         pfluxgrd(ig) = pfluxgrd(ig)
+     s   + pcapcal(ig) * (ptsoil(ig,1) * z1(ig,indice)
+     $       - lambda * zc(ig,1,indice)
+     $       - ptsrf(ig))
+     s   /ptimestep
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/stdlevvar.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/stdlevvar.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/stdlevvar.F90	(revision 984)
@@ -0,0 +1,278 @@
+!
+! $Header$
+!
+      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, rugos, psol, pat1, &
+                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar)
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!
+!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
+!
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.h
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_10m--output-R- vitesse du vent a 10m
+!AM
+! t_10m--output-R- temperature de l'air a 10m
+! q_10m--output-R- humidite specifique a 10m
+! ustar--output-R- u*
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
+      REAL, dimension(klon), intent(in) :: qsurf, rugos
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
+      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
+!-------------------------------------------------------------------------
+      include "YOMCST.h"
+!IM PLUS
+      include "YOETHF.h"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+!     INTEGER, parameter :: niter=6, ncon=niter-1
+      INTEGER, parameter :: niter=2, ncon=niter-1
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: zri1, cdran
+      REAL, dimension(klon) :: cdram, cdrah
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      REAL, dimension(klon) :: testar, qstar
+      REAL, dimension(klon) :: zdte, zdq   
+! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
+      DOUBLE PRECISION, dimension(klon) :: lmon
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: temp, pref
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+!convertgence
+      REAL, dimension(klon) :: te_zref_con, q_zref_con
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr
+!     REAL, dimension(klon) :: conv_te, conv_q
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+       speed(i)=SQRT(u1(i)**2+v1(i)**2)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+      CALL coefcdrag(klon, knon, nsrf, zxli, &
+ &                   speed, t1, q1, z1, psol, &
+ &                   ts1, qsurf, rugos, okri, ri1,  &         
+ &                   cdram, cdrah, cdran, zri1, pref)            
+!
+!---------Star variables----------------------------------------------------
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
+        zdte(i) = tpot(i) - ts1(i)
+        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
+!
+!
+!IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
+        zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
+!
+        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
+        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
+        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
+ &                (RKAR * RG * testar(i))
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+        q_zref_p(i) = q_zref(i)
+!       te_zref_p(i) = te_zref(i)
+        temp_p(i) = temp(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &           
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq) 
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i) 
+!
+! return to normal temperature
+!
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+!
+!IM +++
+!         IF(temp(i).GT.350.) THEN
+!           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
+!         ENDIF
+!IM ---
+!
+        IF(n.EQ.ncon) THEN
+          te_zref_con(i) = te_zref(i)
+          q_zref_con(i) = q_zref(i)
+        ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
+!
+!       DO i = 1, knon
+!         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
+!         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
+!IM +++
+!         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
+!           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
+!           q_zref_con(i),q_zref(i),conv_q(i)
+!         ENDIF
+!IM ---
+!       ENDDO
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+!       IF(zri1(i).LT.0.) THEN
+!         IF(nsrf.EQ.1) THEN
+!           ok_pred(i)=1.
+!           ok_corr(i)=0.
+!         ELSE
+!           ok_pred(i)=0.
+!           ok_corr(i)=1.
+!         ENDIF
+!       ELSE
+!         ok_pred(i)=0.
+!         ok_corr(i)=1.
+!       ENDIF
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!IM +++
+!       IF(n.EQ.niter) THEN
+!       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
+!         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
+!         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ENDIF
+!       ENDIF
+!IM ---
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+        u_zref_p(i) = u_zref(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq)
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i)
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                   (1 + RVTMP2 * max(q_zref(i),0.0))
+        ENDDO 
+!
+      ENDDO
+!
+      DO i = 1, knon
+        u_zref_c(i) = u_zref(i)
+!
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+!
+!AM
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!MA
+      ENDDO
+! 
+      RETURN
+      END subroutine stdlevvar
Index: LMDZ4/tags/LF_20080728/libf/phytherm/stratocu_if.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/stratocu_if.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/stratocu_if.F90	(revision 984)
@@ -0,0 +1,78 @@
+  SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t &
+,seuil_inversion,weak_inversion,dthmin)
+implicit none
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! klon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! weak_inversion-----logical
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: klon,klev
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, 4), INTENT(IN)   ::  pctsrf
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t
+    
+    REAL, DIMENSION(klon), INTENT(OUT)  :: weak_inversion
+!
+! Quelques constantes et options:
+!
+    REAL seuil_inversion ! au-dela l'inversion est consideree trop faible
+!    PARAMETER (seuil=-0.1)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(klon)
+    REAL zl2(klon)
+    REAL dthmin(klon), zdthdp
+
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+!
+! Chercher la zone d'inversion forte
+!
+
+    DO i = 1, klon
+       invb(i) = klev
+       dthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, klon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.dthmin(i) ) THEN
+             dthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+!
+! Introduire une diffusion:
+!
+    DO i = 1, klon
+       IF ( (pctsrf(i,is_oce) < 0.5) .OR. &
+          (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN 
+          weak_inversion(i)=1.
+       ELSE
+          weak_inversion(i)=0.
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE stratocu_if
Index: LMDZ4/tags/LF_20080728/libf/phytherm/suphec.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/suphec.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/suphec.F	(revision 984)
@@ -0,0 +1,211 @@
+!
+! $Header$
+!
+      SUBROUTINE suphec
+C
+#include "YOMCST.h"
+#include "YOETHF.h"
+cIM cf. JLD
+       LOGICAL firstcall
+       SAVE firstcall
+c$OMP THREADPRIVATE(firstcall)
+       DATA firstcall /.TRUE./
+       
+       IF (firstcall) THEN
+         PRINT*, 'suphec initialise les constantes du GCM'
+         firstcall = .FALSE.
+       ELSE
+         PRINT*, 'suphec DEJA APPELE '
+         RETURN
+       ENDIF
+C      -----------------------------------------------------------------
+C
+C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
+C              -----------------------------
+C
+      WRITE(UNIT=6,FMT='(''0*** Constants of the ICM   ***'')')
+      RPI=2.*ASIN(1.)
+      RCLUM=299792458.
+      RHPLA=6.6260755E-34
+      RKBOL=1.380658E-23
+      RNAVO=6.0221367E+23
+      WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')')
+      WRITE(UNIT=6,FMT='(''           PI = '',E13.7,'' -'')')RPI
+      WRITE(UNIT=6,FMT='(''            c = '',E13.7,''m s-1'')')
+     S RCLUM
+      WRITE(UNIT=6,FMT='(''            h = '',E13.7,''J s'')')
+     S RHPLA
+      WRITE(UNIT=6,FMT='(''            K = '',E13.7,''J K-1'')')
+     S RKBOL
+      WRITE(UNIT=6,FMT='(''            N = '',E13.7,''mol-1'')')
+     S RNAVO
+C
+C     ----------------------------------------------------------------
+C
+C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
+C              ------------------------------
+C
+      RDAY=86400.
+      REA=149597870000.
+      REPSM=0.409093
+C
+      RSIYEA=365.25*RDAY*2.*RPI/6.283076
+      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
+      ROMEGA=2.*RPI/RSIDAY
+c
+c exp1      R_ecc = 0.05
+c exp1      R_peri = 102.04
+c exp1      R_incl = 22.5
+c exp1      print*, 'Parametres orbitaux modifies'
+c ref      R_ecc = 0.016724
+c ref      R_peri = 102.04
+c ref      R_incl = 23.5
+c
+cIM 161002 : pour avoir les ctes AMIP II
+cIM 161002   R_ecc = 0.016724
+cIM 161002   R_peri = 102.04
+cIM 161002   R_incl = 23.5
+cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
+c     R_ecc = 0.016715
+c     R_peri = 102.7
+c     R_incl = 23.441
+c
+      WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')')
+      WRITE(UNIT=6,FMT='(''          day = '',E13.7,'' s'')')RDAY
+      WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA
+      WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
+      WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA
+      WRITE(UNIT=6,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
+      WRITE(UNIT=6,FMT='(''        omega = '',E13.7,'' s-1'')')
+     S                  ROMEGA
+c     write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+c     write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+c     write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+C
+C     ------------------------------------------------------------------
+C
+C*       3.    DEFINE GEOIDE.
+C              --------------
+C
+      RG=9.80665
+      RA=6371229.
+      R1SA=SNGL(1.D0/DBLE(RA))
+      WRITE(UNIT=6,FMT='('' ***         Geoide         ***'')')
+      WRITE(UNIT=6,FMT='(''      Gravity = '',E13.7,'' m s-2'')')
+     S      RG
+      WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA
+      WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA
+C
+C     -----------------------------------------------------------------
+C
+C*       4.    DEFINE RADIATION CONSTANTS.
+C              ---------------------------
+C
+c z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+      rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15.
+cIM init. dans conf_phys.F90   RI0=1365.
+      WRITE(UNIT=6,FMT='('' ***        Radiation       ***'')')
+      WRITE(UNIT=6,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''
+     S )')  RSIGMA
+cIM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
+cIM init. dans conf_phys.F90  S      RI0
+C
+C     -----------------------------------------------------------------
+C
+C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+C              ------------------------------------------
+C
+      R=RNAVO*RKBOL
+      RMD=28.9644
+      RMO3=47.9942
+      RMV=18.0153
+      RD=1000.*R/RMD
+      RV=1000.*R/RMV
+      RCPD=3.5*RD
+      RCVD=RCPD-RD
+      RCPV=4. *RV
+      RCVV=RCPV-RV
+      RKAPPA=RD/RCPD
+      RETV=RV/RD-1.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas     ***'')')
+      WRITE(UNIT=6,FMT='('' Perfect gas  = '',e13.7)') R
+      WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD
+      WRITE(UNIT=6,FMT='('' Ozone   mass = '',e13.7)') RMO3
+      WRITE(UNIT=6,FMT='('' Vapour  mass = '',e13.7)') RMV
+      WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD
+      WRITE(UNIT=6,FMT='('' Vapour  cst. = '',e13.7)') RV
+      WRITE(UNIT=6,FMT='(''         Cpd  = '',e13.7)') RCPD
+      WRITE(UNIT=6,FMT='(''         Cvd  = '',e13.7)') RCVD
+      WRITE(UNIT=6,FMT='(''         Cpv  = '',e13.7)') RCPV
+      WRITE(UNIT=6,FMT='(''         Cvv  = '',e13.7)') RCVV
+      WRITE(UNIT=6,FMT='(''      Rd/Cpd  = '',e13.7)') RKAPPA
+      WRITE(UNIT=6,FMT='(''     Rv/Rd-1  = '',e13.7)') RETV
+C
+C     ----------------------------------------------------------------
+C
+C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+C              ---------------------------------------------
+C
+      RCW=RCPV
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid  ***'')')
+      WRITE(UNIT=6,FMT='(''         Cw   = '',E13.7)') RCW
+C
+C     ----------------------------------------------------------------
+C
+C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+C              --------------------------------------------
+C
+      RCS=RCPV
+      WRITE(UNIT=6,FMT='('' *** thermodynamic, solid   ***'')')
+      WRITE(UNIT=6,FMT='(''         Cs   = '',E13.7)') RCS
+C
+C     ----------------------------------------------------------------
+C
+C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+C              ----------------------------------------------------
+C
+      RTT=273.16
+      RLVTT=2.5008E+6
+      RLSTT=2.8345E+6
+      RLMLT=RLSTT-RLVTT
+      RATM=100000.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans.  ***'')')
+      WRITE(UNIT=6,FMT='('' Fusion point  = '',E13.7)') RTT
+      WRITE(UNIT=6,FMT='(''        RLvTt  = '',E13.7)') RLVTT
+      WRITE(UNIT=6,FMT='(''        RLsTt  = '',E13.7)') RLSTT
+      WRITE(UNIT=6,FMT='(''        RLMlt  = '',E13.7)') RLMLT
+      WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM
+      WRITE(UNIT=6,FMT='('' Latent heat :  '')')
+C
+C     ----------------------------------------------------------------
+C
+C*       9.    SATURATED VAPOUR PRESSURE.
+C              --------------------------
+C
+      RESTT=611.14
+      RGAMW=(RCW-RCPV)/RV
+      RBETW=RLVTT/RV+RGAMW*RTT
+      RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
+      RGAMS=(RCS-RCPV)/RV
+      RBETS=RLSTT/RV+RGAMS*RTT
+      RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
+      RGAMD=RGAMS-RGAMW
+      RBETD=RBETS-RBETW
+      RALPD=RALPS-RALPW
+C
+C     ------------------------------------------------------------------
+c
+c calculer les constantes pour les fonctions thermodynamiques
+c
+      RVTMP2=RCPV/RCPD-1.
+      RHOH2O=RATM/100.
+      R2ES=RESTT*RD/RV
+      R3LES=17.269
+      R3IES=21.875
+      R4LES=35.86
+      R4IES=7.66
+      R5LES=R3LES*(RTT-R4LES)
+      R5IES=R3IES*(RTT-R4IES)
+C
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_bucket_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_bucket_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_bucket_mod.F90	(revision 984)
@@ -0,0 +1,317 @@
+!
+! $Header$
+!
+MODULE surf_land_bucket_mod
+!
+! Surface land bucket module
+!
+! This module is used when no external land model is choosen.
+!
+  USE fonte_neige_mod
+  USE calcul_fluxs_mod
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+ 
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+       spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, ps, &
+       u1_lay, v1_lay, rugoro, &
+       radsol, snow, qsol, agesno, tsoil, &
+       qsurf, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l)
+
+!****************************************************************************************
+! Bucket calculations for surface. 
+!
+    INCLUDE "clesphys.h"
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    LOGICAL, INTENT(IN)                     :: debut
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: ps
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: soilcap, soilflux
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon) :: alb_neig
+    REAL, DIMENSION(klon) :: zfra
+    INTEGER               :: i
+!
+!****************************************************************************************
+
+
+!
+!* Read from limit.nc : albedo(alb_new), length of rugosity(z0_new)
+!
+    CALL interfsur_lim(itime, dtime, jour, &
+         knon, knindex, debut,  &
+         alb_new, z0_new)
+    
+!
+!* Calcultaion of fluxes 
+!
+! calculate constants
+    CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
+       
+! calculate temperature, heat capacity and conduction flux in soil
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       DO i=1, knon
+          cal(i) = RCPD / soilcap(i)
+          radsol(i) = radsol(i)  + soilflux(i)
+       END DO
+    ELSE 
+       cal(:) = RCPD * capsol(:)
+    ENDIF
+    
+    CALL calcul_fluxs(knon, is_ter, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+!
+!* Calculate snow height, run_off, age of snow
+!      
+    CALL fonte_neige( knon, is_ter, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+!
+!* Calculate the age of snow
+!
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    
+    DO i=1, knon
+       zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0)))
+       alb_new(i)  = alb_neig(i) *zfra(i) + alb_new(i)*(1.0-zfra(i))
+    END DO
+
+    alblw(:) = 0.0
+    alblw(1:knon) = alb_new(1:knon)
+
+!
+!* Calculate the rugosity
+!
+    z0_new = SQRT(z0_new**2+rugoro**2)
+       
+!
+!* End
+!
+  END SUBROUTINE surf_land_bucket
+!
+!****************************************************************************************
+!
+  SUBROUTINE interfsur_lim(itime, dtime, jour, &
+       knon, knindex, debut, &
+       lmt_alb_p, lmt_rug_p)
+    
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_alb_p      Albedo lu 
+!   lmt_rug_p      longueur de rugosite lue
+
+    INCLUDE "netcdf.inc"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime
+    REAL   , INTENT(IN)                      :: dtime
+    INTEGER, INTENT(IN)                      :: jour
+    INTEGER, INTENT(IN)                      :: knon
+    INTEGER, DIMENSION(klon_loc), INTENT(IN) :: knindex
+    LOGICAL, INTENT(IN)                      :: debut
+
+! Output variables
+!****************************************************************************************
+    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_alb_p
+    REAL, INTENT(out), DIMENSION(klon_loc)   :: lmt_rug_p
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER,SAVE   :: lmt_pas     ! frequence de lecture des conditions limites 
+                                  ! (en pas de physique)
+    !$OMP THREADPRIVATE(lmt_pas) 
+    LOGICAL,SAVE   :: deja_lu_sur ! pour indiquer que le jour a lire a deja
+                                  ! lu pour une surface precedente
+    !$OMP THREADPRIVATE(deja_lu_sur) 
+    INTEGER,SAVE                           :: jour_lu_sur 
+    !$OMP THREADPRIVATE(jour_lu_sur) 
+    CHARACTER (len = 20),SAVE              :: fich ='limit.nc'
+    !$OMP THREADPRIVATE(fich) 
+    LOGICAL,SAVE                           :: check = .FALSE.
+    !$OMP THREADPRIVATE(check) 
+! Champs lus dans le fichier de CL
+    REAL, ALLOCATABLE , SAVE, DIMENSION(:) :: alb_lu_p, rug_lu_p
+    !$OMP THREADPRIVATE(alb_lu_p, rug_lu_p) 
+
+! quelques variables pour netcdf
+    INTEGER ,SAVE                          :: nid, nvarid
+    !$OMP THREADPRIVATE(nid, nvarid) 
+    INTEGER, DIMENSION(2),SAVE             :: start, epais
+    !$OMP THREADPRIVATE(start, epais) 
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                :: ii, ierr
+    CHARACTER (len = 20)                   :: modname = 'interfsur_lim'
+    CHARACTER (len = 80)                   :: abort_message
+    REAL, DIMENSION(klon_glo)              :: alb_lu
+    REAL, DIMENSION(klon_glo)              :: rug_lu
+
+!
+! End delaration
+!****************************************************************************************
+
+    IF (debut) THEN
+       lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+       jour_lu_sur = jour - 1
+       ALLOCATE(alb_lu_p(klon_loc))
+       ALLOCATE(rug_lu_p(klon_loc))
+    ENDIF
+    
+    IF ((jour - jour_lu_sur) /= 0) deja_lu_sur = .FALSE.
+  
+    IF (check) WRITE(*,*) modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur 
+    IF (check) WRITE(*,*) modname,':: itime, lmt_pas', itime, lmt_pas
+    IF (check) CALL flush(6)
+
+!    
+! Tester d'abord si c'est le moment de lire le fichier
+!
+    IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu_sur) THEN
+
+!
+! Ouverture et lecture du fichier
+!
+!$OMP MASTER
+       IF (is_mpi_root) THEN
+          fich = TRIM(fich)
+          IF (check) WRITE(*,*)modname,' ouverture fichier ',fich
+          IF (check) CALL flush(6)
+          ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+          IF (ierr.NE.NF_NOERR) THEN
+             abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+! 
+! La tranche de donnees a lire:
+          start(1) = 1
+          start(2) = jour
+          epais(1) = klon_glo
+          epais(2) = 1
+!
+! Lecture albedo
+          ierr = NF_INQ_VARID(nid, 'ALB', nvarid)
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Le champ <ALB> est absent'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, alb_lu)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu)
+#endif
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Lecture echouee pour <ALB>'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+!
+! Lecture rugosite!
+          ierr = NF_INQ_VARID(nid, 'RUG', nvarid)
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Le champ <RUG> est absent'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, rug_lu)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu)
+#endif
+          IF (ierr /= NF_NOERR) THEN
+             abort_message = 'Lecture echouee pour <RUG>'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+
+!
+! Fin de lecture
+          ierr = NF_CLOSE(nid)
+
+       ENDIF ! is_mpi_root
+!$OMP END MASTER
+
+       CALL Scatter(alb_lu,alb_lu_p)
+       CALL Scatter(rug_lu,rug_lu_p)
+
+       deja_lu_sur = .TRUE.
+       jour_lu_sur = jour       
+
+    ENDIF
+  
+!
+! Recopie des variables dans les champs de sortie
+!
+    lmt_alb_p(:) = 999999.
+    lmt_rug_p(:) = 999999.
+    DO ii = 1, knon
+       lmt_alb_p(ii) = alb_lu_p(knindex(ii))
+       lmt_rug_p(ii) = rug_lu_p(knindex(ii))
+    ENDDO
+    
+
+  END SUBROUTINE interfsur_lim
+!
+!****************************************************************************************
+!
+END MODULE surf_land_bucket_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_mod.F90	(revision 984)
@@ -0,0 +1,142 @@
+!
+! $Header$
+!
+MODULE surf_land_mod
+  
+  USE surface_data, ONLY    : ok_veget
+  USE dimphy
+ 
+#ifdef CPP_VEGET
+  USE surf_land_orchidee_mod
+#endif
+  USE surf_land_bucket_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
+       rlon, rlat, &
+       debut, lafin, zlev, epot_air, ccanopy, sollwdown, swnet, swdown, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_ter)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: date0
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    LOGICAL, INTENT(IN)                     :: debut, lafin
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: zlev, epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)       :: sollwdown, swnet, swdown    
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: ps
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_ter
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: ps_tmp, p1lay_tmp
+    REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used
+    INTEGER               :: i
+
+
+!**************************************************************************************** 
+! Choice between call to vegetation model (ok_veget=true) or simple calculation below
+!
+!****************************************************************************************
+   IF (ok_veget) THEN
+!****************************************************************************************
+!  Call model sechiba
+!
+!****************************************************************************************
+       p1lay_tmp(:)      = 0.0
+       ps_tmp(:)         = 0.0
+       p1lay_tmp(1:knon) = p1lay(1:knon)/100.
+       ps_tmp(1:knon)    = ps(1:knon)/100.
+
+#ifdef CPP_VEGET
+       CALL surf_land_orchidee(itime, dtime, date0, knon, &
+            knindex, rlon, rlat, pctsrf, &
+            debut, lafin, &
+            zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+            tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            precip_rain, precip_snow, sollwdown, swnet, swdown, &
+            ps_tmp, &
+            evap, fluxsens, fluxlat, &              
+            tsol_rad, tsurf_new, alb_new, alblw, &
+            emis_new, z0_new, qsurf)       
+#endif
+
+!  
+!* Ajout de la contribution du relief
+!  
+       DO i=1,knon
+          z0_new(i) = SQRT(z0_new(i)**2 + rugoro(i)**2)
+       ENDDO
+
+    ELSE  ! not ok_veget
+!****************************************************************************************
+! No extern vegetation model choosen, call simple bucket calculations instead.
+!
+!****************************************************************************************
+       CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+            tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+            spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, ps, &
+            u1_lay, v1_lay, rugoro, &
+            radsol, snow, qsol, agesno, tsoil, &
+            qsurf, z0_new, alblw, evap, fluxsens, fluxlat, &
+            tsurf_new, alb_new, dflux_s, dflux_l)
+
+    ENDIF ! ok_veget
+
+!****************************************************************************************
+! Return the pourcentage of land in each grid cell, even if not changed in here!
+!
+!****************************************************************************************
+    pctsrf_ter(:) = pctsrf(:,is_ter)
+
+
+  END SUBROUTINE surf_land
+!
+!****************************************************************************************
+!  
+END MODULE surf_land_mod
+!
+!****************************************************************************************
+!  
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_orchidee_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_orchidee_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surf_land_orchidee_mod.F90	(revision 984)
@@ -0,0 +1,701 @@
+!
+! $Header$
+!
+MODULE surf_land_orchidee_mod
+!
+! This module controles the interface towards the model ORCHIDEE
+!
+! Subroutines in this module : surf_land_orchidee
+!                              Init_orchidee_index
+!                              Get_orchidee_communicator
+!                              Init_neighbours
+#ifdef CPP_VEGET
+
+  USE dimphy
+  USE intersurf     ! module d'ORCHIDEE
+  USE cpl_mod,      ONLY : cpl_send_land_fields
+  USE surface_data, ONLY : ocean, ok_veget
+  USE comgeomphy,   ONLY : cuphy, cvphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC  :: surf_land_orchidee
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
+       knindex, rlon, rlat, pctsrf, &
+       debut, lafin, &
+       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       precip_rain, precip_snow, lwdown, swnet, swdown, &
+       ps, &
+       evap, fluxsens, fluxlat, &              
+       tsol_rad, tsurf_new, alb_new, alblw, &
+       emis_new, z0_new, qsurf)
+!    
+! Cette routine sert d'interface entre le modele atmospherique et le 
+! modele de sol continental. Appel a sechiba
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes de la grille entiere
+!   rlat         latitudes de la grille entiere
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   debut        logical: 1er appel a la physique (lire les restart)
+!   lafin        logical: dernier appel a la physique (ecrire les restart)
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   plev         hauteur de la premiere couche (Pa)      
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp pot de l'air
+!   ccanopy      concentration CO2 canopee
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   lwdown       flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb_new      albedo
+!   emis_new     emissivite
+!   z0_new       surface roughness
+!   qsurf        air moisture at surface
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "temps.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "dimensions.h"
+  
+!
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    REAL, INTENT(IN)                          :: dtime
+    REAL, INTENT(IN)                          :: date0
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    LOGICAL, INTENT(IN)                       :: debut, lafin
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
+    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)         :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)         :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)         :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)         :: lwdown, swnet, swdown, ps
+    REAL, DIMENSION(klon)                     :: swdown_vrai
+
+! Parametres de sortie
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: evap, fluxsens, fluxlat, qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tsol_rad, tsurf_new, alb_new, alblw
+    REAL, DIMENSION(klon), INTENT(OUT)        :: emis_new, z0_new
+
+! Local
+!****************************************************************************************
+    INTEGER                                   :: ij, jj, igrid, ireal, index
+    INTEGER                                   :: error
+    CHARACTER (len = 20)                      :: modname = 'surf_land_orchidee'
+    CHARACTER (len = 80)                      :: abort_message
+    LOGICAL,SAVE                              :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! type de couplage dans sechiba
+!  character (len=10)   :: coupling = 'implicit' 
+! drapeaux controlant les appels dans SECHIBA
+!  type(control_type), save   :: control_in
+! Preserved albedo
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: albedo_keep, zlev
+    !$OMP THREADPRIVATE(albedo_keep,zlev)
+! coordonnees geographiques
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
+    !$OMP THREADPRIVATE(lalo)
+! pts voisins
+    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
+    !$OMP THREADPRIVATE(neighbours)
+! fractions continents
+    REAL,ALLOCATABLE, DIMENSION(:), SAVE      :: contfrac
+    !$OMP THREADPRIVATE(contfrac)
+! resolution de la grille
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: resolution
+    !$OMP THREADPRIVATE(resolution)
+
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: lon_scat, lat_scat  
+    !$OMP THREADPRIVATE(lon_scat,lat_scat)
+
+    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
+    !$OMP THREADPRIVATE(lrestart_read)
+    LOGICAL, SAVE                             :: lrestart_write = .FALSE.
+    !$OMP THREADPRIVATE(lrestart_write)
+
+    REAL, DIMENSION(knon,2)                   :: albedo_out
+    !$OMP THREADPRIVATE(albedo_out)
+
+! Pb de nomenclature
+    REAL, DIMENSION(klon)                     :: petA_orc, peqA_orc
+    REAL, DIMENSION(klon)                     :: petB_orc, peqB_orc
+! Pb de correspondances de grilles
+    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  :: ig, jg
+    !$OMP THREADPRIVATE(ig,jg)
+    INTEGER :: indi, indj
+    INTEGER, SAVE, ALLOCATABLE,DIMENSION(:)   :: ktindex
+    !$OMP THREADPRIVATE(ktindex)
+
+! Essai cdrag
+    REAL, DIMENSION(klon)                     :: cdrag
+    INTEGER,SAVE                              :: offset
+    !$OMP THREADPRIVATE(offset)
+
+    REAL, DIMENSION(klon_glo)                 :: rlon_g,rlat_g
+    INTEGER, SAVE                             :: orch_comm
+    !$OMP THREADPRIVATE(orch_comm)
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: coastalflow
+    !$OMP THREADPRIVATE(coastalflow)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: riverflow
+    !$OMP THREADPRIVATE(riverflow)
+!
+! Fin definition
+!****************************************************************************************
+
+    IF (check) WRITE(lunout,*)'Entree ', modname
+    IF (check) WRITE(lunout,*)'ok_veget = ',ok_veget
+  
+! Initialisation
+  
+    IF (debut) THEN
+       ALLOCATE(ktindex(knon))
+       IF ( .NOT. ALLOCATED(albedo_keep)) THEN
+          ALLOCATE(albedo_keep(klon))
+          ALLOCATE(zlev(knon))
+       ENDIF
+! Pb de correspondances de grilles
+       ALLOCATE(ig(klon))
+       ALLOCATE(jg(klon))
+       ig(1) = 1
+       jg(1) = 1
+       indi = 0
+       indj = 2
+       DO igrid = 2, klon - 1
+          indi = indi + 1
+          IF ( indi > iim) THEN
+             indi = 1
+             indj = indj + 1
+          ENDIF
+          ig(igrid) = indi
+          jg(igrid) = indj
+       ENDDO
+       ig(klon) = 1
+       jg(klon) = jjm + 1
+
+       IF ((.NOT. ALLOCATED(lalo))) THEN
+          ALLOCATE(lalo(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lalo'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lon_scat))) THEN
+          ALLOCATE(lon_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lon_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lat_scat))) THEN
+          ALLOCATE(lat_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lat_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       lon_scat = 0.
+       lat_scat = 0.
+       DO igrid = 1, knon
+          index = knindex(igrid)
+          lalo(igrid,2) = rlon(index)
+          lalo(igrid,1) = rlat(index)
+       ENDDO
+
+       
+       
+       CALL Gather(rlon,rlon_g)
+       CALL Gather(rlat,rlat_g)
+
+       IF (is_mpi_root) THEN
+          index = 1
+          DO jj = 2, jjm
+             DO ij = 1, iim
+                index = index + 1
+                lon_scat(ij,jj) = rlon_g(index)
+                lat_scat(ij,jj) = rlat_g(index)
+             ENDDO
+          ENDDO
+          lon_scat(:,1) = lon_scat(:,2)
+          lat_scat(:,1) = rlat_g(1)
+          lon_scat(:,jjm+1) = lon_scat(:,2)
+          lat_scat(:,jjm+1) = rlat_g(klon_glo)
+       ENDIF
+   
+
+!
+! Allouer et initialiser le tableau des voisins et des fraction de continents
+!
+       IF ( (.NOT.ALLOCATED(neighbours))) THEN
+          ALLOCATE(neighbours(knon,8), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation neighbours'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       neighbours = -1.
+       IF (( .NOT. ALLOCATED(contfrac))) THEN
+          ALLOCATE(contfrac(knon), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation contfrac'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       DO igrid = 1, knon
+          ireal = knindex(igrid)
+          contfrac(igrid) = pctsrf(ireal,is_ter)
+       ENDDO
+
+
+       CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
+
+!
+!  Allocation et calcul resolutions
+       IF ( (.NOT.ALLOCATED(resolution))) THEN
+          ALLOCATE(resolution(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation resolution'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       DO igrid = 1, knon
+          ij = knindex(igrid)
+          resolution(igrid,1) = cuphy(ij)
+          resolution(igrid,2) = cvphy(ij)
+       ENDDO
+     
+       ALLOCATE(coastalflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation coastalflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+       ALLOCATE(riverflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation riverflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+
+    ENDIF                          ! (fin debut) 
+
+! 
+! Appel a la routine sols continentaux
+!
+    IF (lafin) lrestart_write = .TRUE.
+    IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
+    
+    petA_orc(1:knon) = petBcoef(1:knon) * dtime
+    petB_orc(1:knon) = petAcoef(1:knon)
+    peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
+    peqB_orc(1:knon) = peqAcoef(1:knon)
+
+    cdrag = 0.
+    cdrag(1:knon) = tq_cdrag(1:knon)
+
+! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
+    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
+
+
+! PF et PASB
+!   where(cdrag > 0.01) 
+!     cdrag = 0.01
+!   endwhere
+!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
+
+!
+! Init Orchidee
+!
+!  if (pole_nord) then 
+!    offset=0
+!    ktindex(:)=ktindex(:)+iim-1
+!  else
+!    offset = klon_mpi_begin-1+iim-1
+!    ktindex(:)=ktindex(:)+MOD(offset,iim)
+!    offset=offset-MOD(offset,iim)
+!  endif
+  
+    IF (debut) THEN
+       CALL Get_orchidee_communicator(knon,orch_comm)
+       IF (knon /=0) THEN
+          CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+
+#ifndef CPP_PARA
+#define ORC_PREPAR
+#endif
+#ifdef ORC_PREPAR
+          ! Interface for ORCHIDEE version 1.9 or earlier compiled in sequential mode(without preprocessing flag CPP_PARA)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
+               lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+               cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+               precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
+               evap, fluxsens, fluxlat, coastalflow, riverflow, &
+               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+               lon_scat, lat_scat)
+
+#else          
+          ! Interface for ORCHIDEE version 1.9 compiled in parallel mode(with preprocessing flag CPP_PARA)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, & 
+               orch_comm, dtime, lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+               cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+               precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), &
+               evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+               tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+               lon_scat, lat_scat)
+#endif
+          
+       ENDIF
+
+       albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+    ENDIF
+
+!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
+    swdown_vrai(1:knon) = swdown(1:knon)
+
+    IF (knon /=0) THEN
+    
+#ifdef ORC_PREPAR
+       ! Interface for ORCHIDEE version 1.9 or earlier compiled in sequential mode(without preprocessing flag CPP_PARA)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, &
+            lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+            cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+            precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
+            evap, fluxsens, fluxlat, coastalflow, riverflow, &
+            tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+            lon_scat, lat_scat)
+       
+#else
+       ! Interface for ORCHIDEE version 1.9 compiled in parallel mode(with preprocessing flag CPP_PARA)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & 
+            orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+            cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+            precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
+            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+            lon_scat, lat_scat)
+#endif
+       
+    ENDIF
+
+    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+!* Send to coupler
+!
+    IF (ocean=='couple') THEN
+       CALL cpl_send_land_fields(itime, knon, knindex, &
+            riverflow, coastalflow)
+    ENDIF
+
+    alb_new(1:knon) = albedo_out(1:knon,1) 
+    alblw(1:knon) = albedo_out(1:knon,2)
+
+! Convention orchidee: positif vers le haut
+    fluxsens(1:knon) = -1. * fluxsens(1:knon)
+    fluxlat(1:knon)  = -1. * fluxlat(1:knon)
+    
+!  evap     = -1. * evap
+
+    IF (debut) lrestart_read = .FALSE.
+    
+  END SUBROUTINE surf_land_orchidee
+!
+!****************************************************************************************
+!
+  SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+    
+    INCLUDE "dimensions.h"
+
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                   :: knon
+    INTEGER, INTENT(IN)                   :: orch_comm
+    INTEGER, DIMENSION(klon), INTENT(IN)  :: knindex
+
+! Output arguments
+!****************************************************************************************
+    INTEGER, INTENT(OUT)                  :: offset
+    INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex
+
+! Local varables
+!****************************************************************************************
+#ifdef CPP_PARA
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: status
+#endif
+
+    INTEGER                               :: MyLastPoint
+    INTEGER                               :: LastPoint
+    INTEGER                               :: mpi_rank_orch
+    INTEGER                               :: mpi_size_orch
+    INTEGER                               :: ierr 
+!
+! End definition
+!****************************************************************************************
+
+    MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1
+    
+    IF (is_parallel) THEN
+#ifdef CPP_PARA    
+       CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr)
+       CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr)
+#endif
+    ELSE
+       mpi_rank_orch=0
+       mpi_size_orch=1
+    ENDIF
+
+    IF (is_parallel) THEN
+       IF (mpi_rank_orch /= 0) THEN
+#ifdef CPP_PARA
+          CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr)
+#endif
+       ENDIF
+       
+       IF (mpi_rank_orch /= mpi_size_orch-1) THEN
+#ifdef CPP_PARA
+          CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr)  
+#endif
+       ENDIF
+    ENDIF
+    
+    IF (mpi_rank_orch == 0) THEN 
+       offset=0
+    ELSE
+       offset=LastPoint-MOD(LastPoint,iim)
+    ENDIF
+    
+    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1	
+    
+
+  END SUBROUTINE  Init_orchidee_index
+!
+!****************************************************************************************
+! 
+  SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
+    
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+
+    INTEGER,INTENT(IN)  :: knon
+    INTEGER,INTENT(OUT) :: orch_comm
+    
+    INTEGER             :: color
+    INTEGER             :: ierr
+!
+! End definition
+!****************************************************************************************
+
+    IF (knon==0) THEN 
+       color = 0
+    ELSE 
+       color = 1
+    ENDIF
+    
+#ifdef CPP_PARA    
+    CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
+#endif
+    
+  END SUBROUTINE Get_orchidee_communicator
+!
+!****************************************************************************************
+!  
+  SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf)
+    
+    INCLUDE "indicesol.h"
+    INCLUDE "dimensions.h"
+#ifdef CPP_PARA
+    INCLUDE 'mpif.h'
+#endif    
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: ktindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: pctsrf
+    
+! Output arguments
+!****************************************************************************************
+    INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: knon_g
+    INTEGER                              :: i, igrid, jj, ij, iglob
+    INTEGER                              :: ierr, ireal, index
+    INTEGER, DIMENSION(0:mpi_size-1)     :: knon_nb
+    INTEGER, DIMENSION(0:mpi_size-1)     :: displs
+    INTEGER, DIMENSION(8,3)              :: off_ini
+    INTEGER, DIMENSION(8)                :: offset  
+    INTEGER, DIMENSION(knon)             :: ktindex_p
+    INTEGER, DIMENSION(iim,jjm+1)        :: correspond
+    INTEGER, ALLOCATABLE, DIMENSION(:)   :: ktindex_g
+    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
+    REAL, DIMENSION(klon_glo)            :: pctsrf_g
+    
+!
+! End definition
+!****************************************************************************************
+
+    IF (is_sequential) THEN
+       knon_nb(:)=knon
+    ELSE  
+       
+#ifdef CPP_PARA  
+       CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+       knon_g=SUM(knon_nb(:))
+       ALLOCATE(ktindex_g(knon_g))
+       ALLOCATE(neighbours_g(knon_g,8))
+       neighbours_g(:,:)=-1
+       displs(0)=0
+       DO i=1,mpi_size-1
+          displs(i)=displs(i-1)+knon_nb(i-1)
+       ENDDO
+    ENDIF
+    
+    ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1
+    
+    IF (is_sequential) THEN
+       ktindex_g(:)=ktindex_p(:)
+    ELSE
+       
+#ifdef CPP_PARA  
+       CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,&
+            displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    CALL Gather(pctsrf,pctsrf_g)
+    
+    IF (is_mpi_root) THEN
+!  Initialisation des offset    
+!
+! offset bord ouest
+       off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
+       off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
+       off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
+! offset point normal
+       off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
+       off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
+       off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
+! offset bord   est
+       off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
+       off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
+       off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
+!
+!
+! Attention aux poles
+!
+       DO igrid = 1, knon_g
+          index = ktindex_g(igrid)
+          jj = INT((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+          correspond(ij,jj) = igrid
+       ENDDO
+       
+       DO igrid = 1, knon_g
+          iglob = ktindex_g(igrid)
+          IF (MOD(iglob, iim) == 1) THEN
+             offset = off_ini(:,1)
+          ELSE IF(MOD(iglob, iim) == 0) THEN
+             offset = off_ini(:,3)
+          ELSE
+             offset = off_ini(:,2)
+          ENDIF
+          DO i = 1, 8
+             index = iglob + offset(i)
+             ireal = (MIN(MAX(1, index - iim + 1), klon_glo))
+             IF (pctsrf_g(ireal) > EPSFRA) THEN
+                jj = INT((index - 1)/iim) + 1
+                ij = index - (jj - 1) * iim
+                neighbours_g(igrid, i) = correspond(ij, jj)
+             ENDIF
+          ENDDO
+       ENDDO
+
+    ENDIF
+    
+    DO i=1,8
+       IF (is_sequential) THEN
+          neighbours(:,i)=neighbours_g(:,i)
+       ELSE
+#ifdef CPP_PARA
+          CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) 
+#endif
+       ENDIF
+    ENDDO
+    
+  END SUBROUTINE Init_neighbours
+!
+!****************************************************************************************
+!
+
+#endif
+
+END MODULE surf_land_orchidee_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surf_landice_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surf_landice_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surf_landice_mod.F90	(revision 984)
@@ -0,0 +1,170 @@
+!
+! $Header$
+!
+MODULE surf_landice_mod
+  
+  USE dimphy
+  USE surface_data,     ONLY : ocean, calice, calsno
+  USE fonte_neige_mod,  ONLY : fonte_neige, run_off_lic
+  USE cpl_mod,          ONLY : cpl_send_landice_fields
+  USE calcul_fluxs_mod, ONLY : calcul_fluxs
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_landice(itime, dtime, knon, knindex, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_lic)
+
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input variables 
+!****************************************************************************************
+    INTEGER, INTENT(IN)                           :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(in)          :: knindex
+    REAL, INTENT(in)                              :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)             :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)             :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)             :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)             :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)             :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)             :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)             :: ps
+    REAL, DIMENSION(klon), INTENT(IN)             :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: pctsrf_lic
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)    :: soilcap, soilflux
+    REAL, DIMENSION(klon)    :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)    :: zfra, alb_neig
+
+! End definition
+!****************************************************************************************
+!
+! Initialize output variables
+    alblw(:) =  999999.
+    alb_new(:) = 999999.
+
+
+!****************************************************************************************
+! Soil calculations
+! 
+!****************************************************************************************
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_lic, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon)  = radsol(1:knon) + soilflux(1:knon)
+    ELSE 
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno
+    ENDIF
+
+
+!****************************************************************************************
+! Calulate fluxes
+!
+!****************************************************************************************
+    beta(:) = 1.0
+    dif_grnd(:) = 0.0
+
+    CALL calcul_fluxs(knon, is_lic, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+
+!****************************************************************************************
+! Calculate snow height, age, run-off,..
+!    
+!****************************************************************************************
+    CALL fonte_neige( knon, is_lic, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb_new(1:knon)  = alb_neig(1:knon)*zfra(1:knon) + &
+         0.6 * (1.0-zfra(1:knon))
+!
+!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux"
+!       alb_new(1 : knon)  = 0.6 !IM cf FH/GK 
+!       alb_new(1 : knon)  = 0.82
+!       alb_new(1 : knon)  = 0.77 !211003 Ksta0.77
+!       alb_new(1 : knon)  = 0.8 !KstaTER0.8 & LMD_ARMIP5
+!IM: KstaTER0.77 & LMD_ARMIP6    
+
+! Attantion: alb_new and alblw are the same!
+    alb_new(1:knon)  = 0.77
+    alblw(1:knon)    = alb_new(1:knon)
+
+
+!****************************************************************************************
+! Rugosity
+!
+!****************************************************************************************
+    z0_new(:) = rugoro(:)
+
+
+!****************************************************************************************
+! Return the pourcentage for this sub-surface
+!
+!****************************************************************************************
+    pctsrf_lic(:) = pctsrf(:,is_lic)
+    
+
+!****************************************************************************************
+! Send run-off on land-ice to coupler if coupled ocean.
+! run_off_lic has been calculated in fonte_neige
+!
+!****************************************************************************************
+    IF (ocean=='couple') THEN
+       CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic)
+    ENDIF
+
+
+  END SUBROUTINE surf_landice
+!
+!****************************************************************************************
+!
+END MODULE surf_landice_mod
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surf_ocean_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surf_ocean_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surf_ocean_mod.F90	(revision 984)
@@ -0,0 +1,164 @@
+!
+! $Header$
+!
+MODULE surf_ocean_mod
+
+  USE dimphy
+  USE surface_data, ONLY     : ocean
+  USE ocean_forced_mod, ONLY : ocean_forced_noice
+  USE ocean_slab_mod, ONLY   : ocean_slab_noice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_noice
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_ocean(rlon, rlat, sollw, albedo, &
+       rugos, windsp, rmu0, &
+       fder, &
+       itime, dtime, jour, knon, knindex, &
+       debut, swdown, &
+       p1lay, tq_cdrag, coefm, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, agesno, &
+       z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_oce)
+!
+! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, 
+! slab or couple). The calculations of albedo and rugosity for the ocean surface are 
+! done in here because they are identical for the different modes of ocean. 
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    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)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: coefm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+    LOGICAL, INTENT(IN)                      :: debut
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow, qsurf
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_oce
+
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    REAL, DIMENSION(klon) :: alb_eau
+
+! End definition
+!****************************************************************************************
+! 
+! Switch according to type of ocean (couple, slab or forced)
+!****************************************************************************************
+    SELECT CASE(ocean)
+    CASE('couple')
+       CALL ocean_cpl_noice(&
+            sollw, albedo, &
+            windsp, &
+            fder, & 
+            itime, dtime, knon, knindex, &
+            swdown, &
+            p1lay, tq_cdrag, precip_rain, precip_snow,temp_air,spechum,&
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, pctsrf, &
+            radsol, snow, qsurf, agesno, &
+            evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+
+    CASE('slab')
+       CALL ocean_slab_noice(&
+            dtime, knon, knindex, &
+            p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, &
+            radsol, snow, qsurf, agesno, &
+            evap, fluxsens, fluxlat, &
+            tsurf_new, &
+            dflux_s, dflux_l, pctsrf_oce)
+       
+    CASE('force')
+       CALL ocean_forced_noice(itime, dtime, jour, knon, knindex, &
+            debut, &
+            p1lay, tq_cdrag, precip_rain, precip_snow, &
+            temp_air, spechum, &
+            petAcoef, peqAcoef, petBcoef, peqBcoef, &
+            ps, u1_lay, v1_lay, &
+            radsol, snow, qsurf, &
+            agesno, &
+            evap, fluxsens, fluxlat, &
+            tsurf_new, dflux_s, dflux_l, pctsrf_oce)
+    END SELECT
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN
+       CALL alboc(FLOAT(jour),rlat,alb_eau)
+    ELSE  ! diurnal cycle
+       CALL alboc_cd(rmu0,alb_eau)
+    ENDIF
+
+    DO i =1, knon
+       alb_new(i) = alb_eau(knindex(i))
+    ENDDO
+
+!****************************************************************************************
+! Calculate the rugosity
+!
+!****************************************************************************************
+    z0_new = SQRT(rugos**2 + rugoro**2)
+
+    ! The rugosity is recalculated with another method
+    z0_new(:) = 0.0
+    DO i = 1, knon
+       z0_new(i) = 0.018*coefm(i) * (u1_lay(i)**2+v1_lay(i)**2)/RG  &
+            +  0.11*14e-6 / SQRT(coefm(i) * (u1_lay(i)**2+v1_lay(i)**2))
+       z0_new(i) = MAX(1.5e-05,z0_new(i))
+    ENDDO
+    
+    alblw(1:knon) = alb_new(1:knon)
+!
+!****************************************************************************************
+!    
+  END SUBROUTINE surf_ocean
+!
+!****************************************************************************************
+!
+END MODULE surf_ocean_mod
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surf_seaice_mod.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surf_seaice_mod.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surf_seaice_mod.F90	(revision 984)
@@ -0,0 +1,133 @@
+!
+! $Header$
+!
+MODULE surf_seaice_mod
+
+  USE dimphy
+  USE surface_data, ONLY     : ocean
+  USE ocean_slab_mod, ONLY   : ocean_slab_ice
+  USE ocean_forced_mod, ONLY : ocean_forced_ice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_ice
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_seaice( & 
+       rlon, rlat, sollw, albedo, &
+       fder, &
+       itime, dtime, jour, knon, knindex, &
+       debut, lafin, swdown, &
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       ps, u1_lay, v1_lay, rugoro, pctsrf, &
+       radsol, snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alblw, evap, fluxsens, fluxlat, &
+       tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+!
+! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, 
+! slab or couple). The calculation of rugosity for the sea-ice surface is also done
+! in here because it is the same calculation for the different modes of ocean.
+!
+    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: debut, lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: sollw
+    REAL, DIMENSION(klon), INTENT(IN)        :: albedo
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder
+    REAL, DIMENSION(klon), INTENT(IN)        :: swdown    
+    REAL, DIMENSION(klon), INTENT(IN)        :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsurf, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alblw
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new, alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: pctsrf_sic
+
+! End definitions
+!****************************************************************************************
+
+!****************************************************************************************
+! Switch according to type of ocean (couple, slab or forced)
+!
+!****************************************************************************************
+    SELECT CASE(ocean)
+    CASE('couple')
+       CALL ocean_cpl_ice( &
+          rlon, rlat, sollw, albedo, & 
+          fder, & 
+          itime, dtime, knon, knindex, &
+          lafin,&
+          swdown, &
+          p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, pctsrf, &
+          radsol, snow, qsurf, &
+          alblw, evap, fluxsens, fluxlat, &
+          tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+
+    CASE('slab')
+       CALL ocean_slab_ice( & 
+          itime, dtime, jour, knon, knindex, &
+          debut, &
+          tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, &
+          radsol, snow, qsurf, qsol, agesno, &
+          tsoil, &
+          alblw, evap, fluxsens, fluxlat, &
+          tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+    
+    CASE('force')
+       CALL ocean_forced_ice(itime, dtime, jour, knon, knindex, &
+          debut, &
+          tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, spechum,&
+          petAcoef, peqAcoef, petBcoef, peqBcoef, &
+          ps, u1_lay, v1_lay, &
+          radsol, snow, qsurf, qsol, agesno, &
+          tsoil, alblw, evap, fluxsens, fluxlat, &
+          tsurf_new, alb_new, dflux_s, dflux_l, pctsrf_sic)
+    END SELECT
+
+!****************************************************************************************
+! Calculate rugosity
+!
+!****************************************************************************************
+    z0_new = 0.002
+    z0_new = SQRT(z0_new**2+rugoro**2)
+
+
+  END SUBROUTINE surf_seaice
+!
+!****************************************************************************************
+!
+END MODULE surf_seaice_mod
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/surface_data.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/surface_data.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/surface_data.F90	(revision 984)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!
+MODULE surface_data
+
+  USE dimphy, ONLY : klon
+
+  REAL, PARAMETER        :: calice=1.0/(5.1444e+06*0.15)
+  REAL, PARAMETER        :: tau_gl=86400.*5.
+  REAL, PARAMETER        :: calsno=1./(2.3867e+06*.15)
+  
+  LOGICAL, SAVE          :: ok_veget       ! true for use of vegetation model ORCHIDEE
+  !$OMP THREADPRIVATE(ok_veget)
+  CHARACTER(len=6), SAVE :: ocean          ! force/slab/couple
+  !$OMP THREADPRIVATE(ocean)
+
+END MODULE surface_data
Index: LMDZ4/tags/LF_20080728/libf/phytherm/tetalevel.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/tetalevel.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/tetalevel.F	(revision 984)
@@ -0,0 +1,141 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE tetalevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+c
+cym#include "paramet.h"
+c
+      INTEGER,ALLOCATABLE,SAVE :: lt(:), lb(:)
+      REAL,ALLOCATABLE,SAVE    :: aist(:), aisb(:)
+      REAL,SAVE :: ptop, pbot 
+      LOGICAL,SAVE :: first = .TRUE.
+c$OMP THREADPRIVATE(lt,lb,aist,aisb,ptop, pbot,first)
+
+      INTEGER i, k
+c
+c     PRINT*,'tetalevel pres=',pres
+      IF (first) THEN
+        ALLOCATE(lt(ilon), lb(ilon))
+	ALLOCATE(aist(ilon), aisb(ilon))
+	
+	first=.FALSE.
+      ENDIF
+c=====================================================================
+      if (lnew) then
+c   on r�nitialise les r�ndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, ilon
+cIM      IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+         IF ( ABS(pres-pgcm(i,ilev) ) .GT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+cIM   PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)',
+cIM  .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1))
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, ilon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+cIM         IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+            IF (ptop.GE.pres .AND. pbot.LE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, ilon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Fr��ic Hourdin (3/01/02)
+
+c       IF(pgcm(i,lb(i)).NE.0.OR.
+c    $     pgcm(i,lt(i)).NE.0.) THEN
+c
+c       PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i),
+c    .  lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres
+c
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,ilon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+cIM      PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i),
+cIM  $   Qgcm(i,lt(i)),aist(i),Qpres(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, ilon
+cIM      if (pgcm(i,1).LT.pres) THEN
+         if (pgcm(i,1).GT.pres) THEN
+c           Qpres(i)=1e33
+            Qpres(i)=1e+20
+cIM         PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell.F	(revision 984)
@@ -0,0 +1,1259 @@
+      SUBROUTINE calcul_sec(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev
+     s                  ,pu,pv,pt,po
+     s                  ,zmax,wmax,zw2,lmix
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+ 
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real zalim(klon)
+      integer lalim(klon)
+      real norme(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical therm
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+climitation de la valeur du lentr
+c      do ig=1,ngrid
+c         lentr(ig)=min(5,lentr(ig))
+c      enddo
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+cinitialisations
+      do ig=1,ngrid
+         zalim(ig)=0.
+         norme(ig)=0.
+         lalim(ig)=1
+      enddo
+      do k=1,klev-1
+         do ig=1,ngrid
+       zalim(ig)=zalim(ig)+zlev(ig,k)*MAX(0.,(ztv(ig,k)-ztv(ig,k+1))
+     s          /(zlev(ig,k+1)-zlev(ig,k)))
+c     s         *(zlev(ig,k+1)-zlev(ig,k))
+       norme(ig)=norme(ig)+MAX(0.,(ztv(ig,k)-ztv(ig,k+1))
+     s          /(zlev(ig,k+1)-zlev(ig,k)))
+c    s          *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+       enddo
+       do ig=1,ngrid
+          if (norme(ig).gt.1.e-10) then
+             zalim(ig)=max(10.*zalim(ig)/norme(ig),zlev(ig,2))
+c             zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig)))
+          endif
+       enddo
+cdétermination du lalim correspondant
+      do k=1,klev-1
+         do ig=1,ngrid
+      if ((zalim(ig).gt.zlev(ig,k)).and.(zalim(ig).le.zlev(ig,k+1))) 
+     s   then
+         lalim(ig)=k
+      endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.lt.lentr(ig)) then 
+                 entr_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)
+c     s                           *(zlev(ig,l+1)-zlev(ig,l))
+     s                           *sqrt(zlev(ig,l+1))
+cautre def
+c                entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
+            endif
+         enddo
+      enddo
+cnouveau test
+c      if (therm) then
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lalim(ig)
+     s          .and.zalim(ig).gt.1.e-10) then 
+c            if (l.le.lentr(ig)) then 
+c               entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zalim(ig)))**(3./2.)
+c               write(10,*)zlev(ig,l),entr_star(ig,l)
+            endif
+         enddo
+      enddo
+c      endif
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (entr_star_tot(ig).gt.1.e-10) then
+c         do l=1,lentr(ig)
+          do l=1,klev
+cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            entr_star(ig,l)=entr_star(ig,l)/entr_star_tot(ig)
+         enddo
+         endif
+      enddo
+c
+c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+c         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+c         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+            lentr(ig)=1
+            lalim(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+      do ig=1,ngrid
+c      write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
+      enddo
+con stoppe après les calculs de zmax et wmax
+      RETURN
+
+c      print*,'avant fermeture'
+c Fermeture,determination de f
+cAttention! entrainement normalisé ou pas?
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+c             do k=lmin(ig),lalim(ig) 
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))
+c     s            *entr_star_tot(ig)
+ctest
+c             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+     s             *wmax(ig))
+c             endif
+         endif
+         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+c      print*,'apres fermeture'
+con stoppe après la fermeture
+      RETURN
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+con stoppe après le calcul de entr
+c      RETURN
+cCR:test pour entrainer moins que la masse
+c       do ig=1,ngrid
+c          do l=1,lentr(ig)
+c             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+c                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+c     s                       -0.9*masse(ig,l)/ptimestep
+c                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+c             endif
+c          enddo
+c       enddo
+cCR: fin test
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+c                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+cRC
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+c      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c      print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE fermeture_seche(ngrid,nlay
+     s                ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk
+     s                ,alim_star,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect
+     s                ,zmax,wmax)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+
+      INTEGER ngrid,nlay
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+      real zlev(klon,klev+1)
+      real alim_star(klon,klev)
+      real f0(klon)
+      integer lentr(klon)
+      integer lmin(klon)
+      real zmax(klon)
+      real wmax(klon)
+      real nu_min
+      real nu_max
+      real r_aspect
+      real rhobarz(klon,klev+1)
+      REAL zh(klon,klev)
+      real zo(klon,klev)
+      real zpspsk(klon,klev)
+
+      integer ig,l
+
+      real f_star(klon,klev+1)
+      real detr_star(klon,klev)
+      real entr_star(klon,klev)
+      real zw2(klon,klev+1)
+      real linter(klon)
+      integer lmix(klon)
+      integer lmax(klon)
+      real zlevinter(klon)
+      real wa_moy(klon,klev+1)
+      real wmaxa(klon)
+      REAL ztv(klon,klev)
+      REAL ztva(klon,klev)
+      real nu(klon,klev)
+      real zmax0_sec(klon)
+      save zmax0_sec
+
+      do l=1,nlay
+         do ig=1,ngrid
+      ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+      ztv(ig,l)=ztv(ig,l)*(1.+RETV*zo(ig,l))
+         enddo
+      enddo
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.alim_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=alim_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+cestimation du detrainement a partir de la geometrie du pas precedent
+ctests sur la definition du detr
+             nu(ig,l)=(nu_min+nu_max)/2.
+     s         *(1.-(nu_max-nu_min)/(nu_max+nu_min)
+     s  *tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005)))
+         
+             detr_star(ig,l)=rhobarz(ig,l)
+     s                      *sqrt(zw2(ig,l)) 
+     s                       /(r_aspect*zmax0_sec(ig))*
+c     s                       /(r_aspect*zmax0(ig))*
+     s                      (sqrt(nu(ig,l)*zlev(ig,l+1)
+     s                /sqrt(zw2(ig,l)))
+     s                     -sqrt(nu(ig,l)*zlev(ig,l)
+     s                /sqrt(zw2(ig,l))))
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+         endif
+         entr_star(ig,l)=0.9*detr_star(ig,l)
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+c                 detr_star(ig,l)=0.
+             endif 
+            print*,'ok detr_star'
+cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+     s                      -detr_star(ig,l)
+ctest sur le signe de f_star
+       if ((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10) then 
+cAM on melange Tl et qt du thermique
+          ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig,l)
+     s                    +alim_star(ig,l))
+     s                    *ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)
+     s                     /(f_star(ig,l+1)+detr_star(ig,l)))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+        endif
+c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               print*,'linter=',linter(ig)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+cpour le cas ou on prend tjs lmin=1
+c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0_sec(ig)=zmax(ig)
+      enddo
+       
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell.h	(revision 984)
@@ -0,0 +1,8 @@
+      integer iflag_thermals,nsplit_thermals
+      real r_aspect_thermals,l_mix_thermals,tho_thermals
+      integer w2di_thermals,isplit
+
+      common/ctherm1/iflag_thermals,nsplit_thermals
+      common/ctherm2/r_aspect_thermals,l_mix_thermals,tho_thermals
+      common/ctherm3/w2di_thermals
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_closure.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_closure.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_closure.F90	(revision 984)
@@ -0,0 +1,67 @@
+      SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,zmax_sec,wmax_sec,zmax,wmax,f,f0,lev_out)
+
+!-------------------------------------------------------------------------
+!thermcell_closure: fermeture, determination de f
+!-------------------------------------------------------------------------
+      IMPLICIT NONE
+
+      INTEGER ngrid,nlay
+      INTEGER ig,k       
+      REAL r_aspect,ptimestep
+      integer lev_out                           ! niveau pour les print
+
+      INTEGER lalim(ngrid)
+      REAL alim_star(ngrid,nlay)
+      REAL rho(ngrid,nlay)
+      REAL zlev(ngrid,nlay)
+      REAL zmax(ngrid),zmax_sec(ngrid)
+      REAL wmax(ngrid),wmax_sec(ngrid)
+      real zdenom
+
+      REAL alim_star2(ngrid)
+
+      REAL f(ngrid)
+      REAL f0(ngrid)
+
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (alim_star(ig,1).LT.1.e-10) then
+            f(ig)=0.
+         else   
+             do k=1,lalim(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
+     &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             zdenom=max(500.,zmax(ig))*r_aspect*alim_star2(ig)
+             if (zdenom<1.e-14) then
+                print*,'ig=',ig
+                print*,'alim_star2',alim_star2(ig)
+                print*,'zmax',zmax(ig)
+                print*,'r_aspect',r_aspect
+                print*,'zdenom',zdenom
+                print*,'alim_star',alim_star(ig,:)
+                print*,'zmax_sec',zmax_sec(ig)
+                print*,'wmax_sec',wmax_sec(ig)
+                stop
+             endif
+             if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then 
+             f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect  &
+     &             *alim_star2(ig))
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
+     &                     zmax_sec(ig))*wmax_sec(ig))
+             else
+             f(ig)=wmax(ig)/zdenom
+            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
+     &                     zmax(ig))*wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+      enddo
+      if (lev_out.ge.1) print*,'apres fermeture'
+
+!
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dq.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dq.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dq.F90	(revision 984)
@@ -0,0 +1,99 @@
+      subroutine thermcell_dq(ngrid,nlay,ptimestep,fm,entr,  &
+     &           masse,q,dq,qa,lev_out)
+      implicit none
+
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1)
+
+      integer ig,k
+
+!   calcul du detrainement
+
+      if (lev_out.ge.1) print*,'Q2 THERMCEL_DQ 0'
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+!           print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k)
+!test
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+!               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+!     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+!               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+!               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
+     &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+!             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+!               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)  &
+     &               -wqd(ig,k)+wqd(ig,k+1))  &
+     &               /masse(ig,k)
+!            if (dq(ig,k).lt.0.) then
+!               print*,'dq<0!!!'
+!            endif
+         enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dry.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dry.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dry.F90	(revision 984)
@@ -0,0 +1,209 @@
+       SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                            lalim,lmin,zmax,wmax,lev_out)
+
+!--------------------------------------------------------------------------
+!thermcell_dry: calcul de zmax et wmax du thermique sec
+!--------------------------------------------------------------------------
+       IMPLICIT NONE
+#include "YOMCST.h"       
+       INTEGER l,ig
+
+       INTEGER ngrid,nlay
+       REAL zlev(ngrid,nlay+1)
+       REAL pphi(ngrid,nlay)
+       REAl ztv(ngrid,nlay)
+       REAL alim_star(ngrid,nlay)
+       INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+       REAL zmax(ngrid)
+       REAL wmax(ngrid)
+
+!variables locales
+       REAL zw2(ngrid,nlay+1)
+       REAL f_star(ngrid,nlay+1)
+       REAL ztva(ngrid,nlay+1)
+       REAL wmaxa(ngrid)
+       REAL wa_moy(ngrid,nlay+1)
+       REAL linter(ngrid),zlevinter(ngrid)
+       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
+
+!initialisations
+       do ig=1,ngrid
+          do l=1,nlay+1
+             zw2(ig,l)=0.
+             wa_moy(ig,l)=0.
+          enddo
+       enddo
+       do ig=1,ngrid
+          do l=1,nlay
+             ztva(ig,l)=ztv(ig,l)
+          enddo
+       enddo
+       do ig=1,ngrid
+          wmax(ig)=0.
+          wmaxa(ig)=0.
+       enddo
+!calcul de la vitesse a partir de la CAPE en melangeant thetav
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A eliminer
+! Ce if complique etait fait pour reperer la premiere couche instable
+! Ici, c'est lmin.
+!
+!       do l=1,nlay-2
+!         do ig=1,ngrid
+!            if (ztv(ig,l).gt.ztv(ig,l+1)  &
+!     &         .and.alim_star(ig,l).gt.1.e-10  &
+!     &         .and.zw2(ig,l).lt.1e-10) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! Calcul des F^*, integrale verticale de E^*
+       f_star(:,1)=0.
+       do l=1,nlay
+          f_star(:,l+1)=f_star(:,l)+alim_star(:,l)
+       enddo
+
+! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise
+       linter(:)=0.
+
+! couche la plus haute concernee par le thermique. 
+       lmax(:)=1
+
+! Le niveau linter est une variable continue qui se trouve dans la couche
+! lmax
+
+       do l=1,nlay-2
+         do ig=1,ngrid
+            if (l.eq.lmin(ig).and.lalim(ig).gt.1) then
+
+!------------------------------------------------------------------------
+!  Calcul de la vitesse en haut de la premiere couche instable.
+!  Premiere couche du panache thermique
+!------------------------------------------------------------------------
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+
+!------------------------------------------------------------------------
+! Tant que la vitesse en bas de la couche et la somme du flux de masse
+! et de l'entrainement (c'est a dire le flux de masse en haut) sont
+! positifs, on calcul
+! 1. le flux de masse en haut  f_star(ig,l+1)
+! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l)
+! 3. la vitesse au carré en haut zw2(ig,l+1)
+!------------------------------------------------------------------------
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  A eliminer : dans cette version, si zw2 est > 0 on a un therique.
+!  et donc, au dessus, f_star(ig,l+1) est forcement suffisamment 
+!  grand puisque on n'a pas de detrainement.
+!  f_star est une fonction croissante.
+!  c'est donc vraiment sur zw2 uniquement qu'il faut faire le test.
+!           else if ((zw2(ig,l).ge.1e-10).and.  &
+!    &               (f_star(ig,l)+alim_star(ig,l).gt.1.e-10)) then
+!              f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+            else if (zw2(ig,l).ge.1e-10) then
+
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l)  &
+     &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+  &
+     &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+! determination de zmax continu par interpolation lineaire
+!------------------------------------------------------------------------
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+                print*,'On tombe sur le cas particulier de thermcell_dry'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+                lmax(ig)=l
+            endif
+
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmax(ig)=l
+            endif
+
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+       if (lev_out.ge.1) print*,'fin calcul zw2'
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A eliminer :
+! Ce calcul de lmax est fait en meme temps que celui de linter, plus haut
+! Calcul de la couche correspondant a la hauteur du thermique
+!      do ig=1,ngrid
+!         lmax(ig)=lalim(ig)
+!      enddo
+!      do ig=1,ngrid
+!         do l=nlay,lalim(ig)+1,-1
+!            if (zw2(ig,l).le.1.e-10) then
+!               lmax(ig)=l-1
+!            endif
+!         enddo
+!      enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH A eliminer
+! Simplification
+!          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+!     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+!     &    -zlev(ig,lmax(ig)))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          zlevinter(ig)=zlev(ig,lmax(ig)) + &
+     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
+           zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+! Verification que lalim<=lmax
+      do ig=1,ngrid
+         if(lalim(ig)>lmax(ig)) then
+            print*,'WARNING thermcell_dry ig=',ig,'  lalim=',lalim(ig),'  lmax(ig)=',lmax(ig)
+            lmax(ig)=lalim(ig)
+         endif
+      enddo
+      
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dv2.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dv2.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_dv2.F90	(revision 984)
@@ -0,0 +1,130 @@
+      subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse  &
+     &    ,fraca,larga  &
+     &    ,u,v,du,dv,ua,va,lev_out)
+      implicit none
+
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2
+      real wvd(ngrid,nlay+1),wud(ngrid,nlay+1)
+      real gamma0,gamma(ngrid,nlay+1)
+      real ue(ngrid,nlay),ve(ngrid,nlay)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+!   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+!   On itère sur la valeur du coeff de freinage.
+!              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)  &
+     &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )  &
+     &         *0.5/larga(ig)  &
+     &         *1.
+!    s         *0.5
+!              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+!   la première fois on multiplie le coefficient de freinage
+!   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+!   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+!   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+!                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)  &
+     &               -wud(ig,k)+wud(ig,k+1))  &
+     &               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)  &
+     &               -wvd(ig,k)+wvd(ig,k+1))  &
+     &               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_env.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_env.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_env.F90	(revision 984)
@@ -0,0 +1,136 @@
+      SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
+
+!--------------------------------------------------------------
+!thermcell_env: calcule les caracteristiques de l environnement
+!necessaires au calcul des proprietes dans le thermique
+!--------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"      
+
+      INTEGER ngrid,nlay
+      REAL po(ngrid,nlay)
+      REAL pt(ngrid,nlay)
+      REAL pu(ngrid,nlay)
+      REAL pv(ngrid,nlay)
+      REAL pplay(ngrid,nlay)
+      REAL pplev(ngrid,nlay+1)
+      integer lev_out                           ! niveau pour les print
+
+      REAL zo(ngrid,nlay)
+      REAL zl(ngrid,nlay)
+      REAL zh(ngrid,nlay)
+      REAL ztv(ngrid,nlay)
+      REAL zthl(ngrid,nlay)
+      REAL zpspsk(ngrid,nlay)
+      REAL zu(ngrid,nlay)
+      REAL zv(ngrid,nlay)
+      REAL zqsat(ngrid,nlay)
+
+      INTEGER ig,l,ll
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef,qsatbef
+      real dqsat_dT,DT,num,denom
+      REAL RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      LOGICAL Zsat
+
+      Zsat=.false.
+!
+! Pr Tprec=Tl calcul de qsat 
+! Si qsat>qT T=Tl, q=qT
+! Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+! On cherche DDT < DDT0
+!
+! calcul des caracteristiques de l environnement
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+            zqsat(ig,ll)=0.
+         EndDO
+       EndDO
+!
+!
+!recherche de saturation dans l environnement
+       DO ll=1,nlay
+! les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+            qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll)
+            qsatbef=MIN(0.5,qsatbef)
+            zcor=1./(1.-retv*qsatbef)
+            qsatbef=qsatbef*zcor
+            Zsat = (max(0.,po(ig,ll)-qsatbef) .gt. 1.e-10)
+            if (Zsat) then
+            qlbef=max(0.,po(ig,ll)-qsatbef)
+! si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+! on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (abs(DT).gt.DDT0)
+! il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef=Tbef+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+              qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,ll)
+              qsatbef=MIN(0.5,qsatbef)
+              zcor=1./(1.-retv*qsatbef)
+              qsatbef=qsatbef*zcor
+! on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef
+!          dqsat_dT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef)
+              dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+              num=-Tbef+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              if (denom.lt.1.e-10) then
+                  print*,'pb denom'
+              endif
+              DT=num/denom
+            enddo
+! on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+!          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+!on ecrit zqsat 
+            zqsat(ig,ll)=qsatbef     
+         EndDO
+       EndDO
+!
+!
+!-----------------------------------------------------------------------
+!   incrementation eventuelle de tendances precedentes:
+!   ---------------------------------------------------
+
+      if (lev_out.ge.1) print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+             zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
+             zu(ig,l)=pu(ig,l)
+             zv(ig,l)=pv(ig,l)
+!attention zh est maintenant le profil de T et plus le profil de theta !
+!
+!   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+!Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))  &
+     &           -zl(ig,l))
+!Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+!            
+1015     CONTINUE
+1010  CONTINUE
+ 
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_flux.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_flux.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_flux.F90	(revision 984)
@@ -0,0 +1,503 @@
+!
+! $Header$
+!
+
+
+      SUBROUTINE thermcell_flux(ngrid,klev,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,zmax,lev_out,lunout,igout)
+
+
+!---------------------------------------------------------------------------
+!thermcell_flux: deduction des flux
+!---------------------------------------------------------------------------
+
+      IMPLICIT NONE
+      
+      INTEGER ig,l
+      INTEGER ngrid,klev
+      
+      REAL alim_star(ngrid,klev),entr_star(ngrid,klev)
+      REAL detr_star(ngrid,klev)
+      REAL zw2(ngrid,klev+1)
+      REAL zlev(ngrid,klev+1)
+      REAL masse(ngrid,klev)
+      REAL ptimestep
+      REAL rhobarz(ngrid,klev)
+      REAL f(ngrid)
+      INTEGER lmax(ngrid)
+      INTEGER lalim(ngrid)
+      REAL zqla(ngrid,klev)
+      REAL zmax(ngrid)
+
+      integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha
+      integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8
+      
+
+      REAL entr(ngrid,klev),detr(ngrid,klev)
+      REAL fm(ngrid,klev+1)
+      REAL zfm
+
+      integer igout
+      integer lev_out
+      integer lunout
+
+      REAL f_old,ddd0,eee0,ddd,eee,zzz
+
+      REAL fomass_max,alphamax
+      save fomass_max,alphamax
+
+      fomass_max=0.5
+      alphamax=0.7
+
+      ncorecfm1=0
+      ncorecfm2=0
+      ncorecfm3=0
+      ncorecfm4=0
+      ncorecfm5=0
+      ncorecfm6=0
+      ncorecfm7=0
+      ncorecfm8=0
+      ncorecalpha=0
+
+!initialisation
+      fm(:,:)=0.
+      
+      if (lev_out.ge.10) then
+         write(lunout,*) 'Dans thermcell_flux 0'
+         write(lunout,*) 'flux base ',f(igout)
+         write(lunout,*) 'lmax ',lmax(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) 'ig= ',igout
+         write(lunout,*) ' l E*    A*     D*  '
+         write(lunout,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) &
+     &    ,l=1,lmax(igout))
+      endif
+
+
+!-------------------------------------------------------------------------
+! Verification de la nullite des entrainement et detrainement au dessus
+! de lmax(ig)
+!-------------------------------------------------------------------------
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+               if (entr_star(ig,l).gt.1.) then
+                    print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+!                   stop
+               endif
+            else
+               if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then
+                    print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+                    stop
+               endif
+            endif
+         enddo
+      enddo
+
+!-------------------------------------------------------------------------
+! Multiplication par le flux de masse issu de la femreture
+!-------------------------------------------------------------------------
+
+      do l=1,klev
+         entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l))
+         detr(:,l)=f(:)*detr_star(:,l)
+      enddo
+
+      if (lev_out.ge.10) then
+         write(lunout,*) 'Dans thermcell_flux 1'
+         write(lunout,*) 'flux base ',f(igout)
+         write(lunout,*) 'lmax ',lmax(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) 'ig= ',igout
+         write(lunout,*) ' l   E    D     W2'
+         write(lunout,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) &
+     &    ,zw2(igout,l+1),l=1,lmax(igout))
+      endif
+
+      fm(:,1)=0.
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+      enddo
+
+
+
+! Test provisoire : pour comprendre pourquoi on corrige plein de fois 
+! le cas fm6, on commence par regarder une premiere fois avant les
+! autres corrections.
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm8=ncorecfm8+1
+!              igout=ig
+            endif
+         enddo
+      enddo
+
+      if (lev_out.ge.10) &
+    &    call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,'2  ')
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Version en cours de test;
+! par rapport a thermcell_flux, on fait une grande boucle sur "l"
+! et on modifie le flux avec tous les contrôles appliques d'affilee
+! pour la meme couche
+! Momentanement, on duplique le calcule du flux pour pouvoir comparer
+! les flux avant et apres modif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do l=1,klev
+
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+
+
+!-------------------------------------------------------------------------
+! Verification de la positivite des flux de masse
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+!              print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1)
+                ncorecfm1=ncorecfm1+1
+               fm(ig,l+1)=fm(ig,l)
+               detr(ig,l)=entr(ig,l)
+            endif
+         enddo
+!     enddo
+
+      if (lev_out.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!Test sur fraca croissant
+!-------------------------------------------------------------------------
+
+
+      if (1.eq.0) then
+!     do l=1,klev
+         do ig=1,ngrid
+          if (l.ge.lalim(ig).and.l.le.lmax(ig) &
+     &    .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then
+!  zzz est le flux en l+1 a frac constant
+             zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)  &
+     &                          /(rhobarz(ig,l)*zw2(ig,l))
+             if (fm(ig,l+1).gt.zzz) then
+                detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz
+                fm(ig,l+1)=zzz
+                ncorecfm4=ncorecfm4+1
+             endif
+          endif
+        enddo
+!     enddo
+
+      if (lev_out.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+      else
+         print*,'Test sur les fractions croissantes inhibe dans thermcell_flux2'
+      endif
+
+
+!-------------------------------------------------------------------------
+!test sur flux de masse croissant
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=fm(ig,l)
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+               ncorecfm5=ncorecfm5+1
+            endif
+         enddo
+!     enddo
+
+      if (lev_out.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!detr ne peut pas etre superieur a fm
+!-------------------------------------------------------------------------
+
+      if(1.eq.1) then
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (entr(ig,l)<0.) then
+               print*,'N1 ig,l,entr',ig,l,entr(ig,l)
+               stop'entr negatif'
+            endif
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm6=ncorecfm6+1
+               detr(ig,l)=fm(ig,l)
+!              entr(ig,l)=fm(ig,l+1)
+
+! Dans le cas ou on est au dessus de la couche d'alimentation et que le
+! detrainement est plus fort que le flux de masse, on stope le thermique.
+               if (l.gt.lalim(ig)) then
+                  lmax(ig)=l
+                  fm(ig,l+1)=0.
+                  entr(ig,l)=0.
+               else
+                  ncorecfm7=ncorecfm7+1
+               endif
+            endif
+
+            if(l.gt.lmax(ig)) then
+               detr(ig,l)=0.
+               fm(ig,l+1)=0.
+               entr(ig,l)=0.
+            endif
+
+            if (entr(ig,l).lt.0.) then
+               print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'entr(ig,l)',entr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               stop'probleme dans thermcell flux'
+            endif
+         enddo
+!     enddo
+      endif
+
+
+      if (lev_out.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!fm ne peut pas etre negatif
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
+               fm(ig,l+1)=0.
+!              print*,'fm2<0',l+1,lmax(ig)
+               ncorecfm2=ncorecfm2+1
+            endif
+            if (detr(ig,l).lt.0.) then
+               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'detr(ig,l)',detr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               stop'probleme dans thermcell flux'
+            endif
+        enddo
+!    enddo
+
+      if (lev_out.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-----------------------------------------------------------------------
+!la fraction couverte ne peut pas etre superieure a 1            
+!-----------------------------------------------------------------------
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Partie a revisiter.
+! Il semble qu'etaient codees ici deux optiques dans le cas
+! F/ (rho *w) > 1
+! soit limiter la hauteur du thermique en considerant que c'est 
+! la derniere chouche, soit limiter F a rho w.
+! Dans le second cas, il faut en fait limiter a un peu moins
+! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin
+! dans thermcell_main et qu'il semble de toutes facons deraisonable
+! d'avoir des fractions de 1..
+! Ci dessous, et dans l'etat actuel, le premier des  deux if est
+! sans doute inutile.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    do l=1,klev
+        do ig=1,ngrid
+           if (zw2(ig,l+1).gt.1.e-10) then
+           zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax
+           if ( fm(ig,l+1) .gt. zfm) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=zfm
+!             zw2(ig,l+1)=0.
+!             zqla(ig,l+1)=0.
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+!             lmax(ig)=l+1
+!             zmax(ig)=zlev(ig,lmax(ig))
+!             print*,'alpha>1',l+1,lmax(ig)
+              ncorecalpha=ncorecalpha+1
+           endif
+           endif
+        enddo
+!    enddo
+!
+
+
+      if (lev_out.ge.10) &
+     &   write(lunout,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+! Fin de la grande boucle sur les niveaux verticaux
+      enddo
+
+      if (lev_out.ge.10) &
+    &    call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,'8  ')
+
+
+!-----------------------------------------------------------------------
+! On fait en sorte que la quantite totale d'air entraine dans le 
+! panache ne soit pas trop grande comparee a la masse de la maille
+!-----------------------------------------------------------------------
+
+      if (1.eq.1) then
+      do l=1,klev-1
+         do ig=1,ngrid
+            eee0=entr(ig,l)
+            ddd0=detr(ig,l)
+            eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep
+            ddd=detr(ig,l)-eee
+            if (eee.gt.0.) then
+                ncorecfm3=ncorecfm3+1
+                entr(ig,l)=entr(ig,l)-eee
+                if ( ddd.gt.0.) then
+!   l'entrainement est trop fort mais l'exces peut etre compense par une
+!   diminution du detrainement)
+                   detr(ig,l)=ddd
+                else
+!   l'entrainement est trop fort mais l'exces doit etre compense en partie
+!   par un entrainement plus fort dans la couche superieure
+                   if(l.eq.lmax(ig)) then
+                      detr(ig,l)=fm(ig,l)+entr(ig,l)
+                   else
+                      if(l.ge.lmax(ig).and.0.eq.1) then
+                         print*,'ig,l',ig,l
+                         print*,'eee0',eee0
+                         print*,'ddd0',ddd0
+                         print*,'eee',eee
+                         print*,'ddd',ddd
+                         print*,'entr',entr(ig,l)
+                         print*,'detr',detr(ig,l)
+                         print*,'masse',masse(ig,l)
+                         print*,'fomass_max',fomass_max
+                         print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep
+                         print*,'ptimestep',ptimestep
+                         print*,'lmax(ig)',lmax(ig)
+                         print*,'fm(ig,l+1)',fm(ig,l+1)
+                         print*,'fm(ig,l)',fm(ig,l)
+                         stop'probleme dans thermcell_flux'
+                      endif
+                      entr(ig,l+1)=entr(ig,l+1)-ddd
+                      detr(ig,l)=0.
+                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                      detr(ig,l)=0.
+                   endif
+                endif
+            endif
+         enddo
+      enddo
+      endif
+!                  
+!              ddd=detr(ig)-entre
+!on s assure que tout s annule bien en zmax
+      do ig=1,ngrid
+         fm(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig))
+      enddo
+
+!-----------------------------------------------------------------------
+! Impression du nombre de bidouilles qui ont ete necessaires
+!-----------------------------------------------------------------------
+
+      if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then
+
+          print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',&
+    &     ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', &
+    &     ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', &
+    &     ncorecfm6,'x fm6', &
+    &     ncorecfm7,'x fm7', &
+    &     ncorecfm8,'x fm8', &
+    &     ncorecalpha,'x alpha'
+      endif
+
+      if (lev_out.ge.10) &
+    &    call printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,'fin')
+
+
+      return
+      end
+
+      subroutine printflux(ngrid,klev,lunout,igout,f,lmax,lalim, &
+    &    ptimestep,masse,entr,detr,fm,descr)
+
+     implicit none
+
+      integer ngrid,klev,lunout,igout,l,lm
+
+      integer lmax(klev),lalim(klev)
+      real ptimestep,masse(ngrid,klev),entr(ngrid,klev),detr(ngrid,klev)
+      real fm(ngrid,klev+1),f(ngrid)
+
+      character*3 descr
+
+      lm=lmax(igout)+5
+      if(lm.gt.klev) lm=klev
+
+      print*,'Impression jusque lm=',lm
+
+         write(lunout,*) 'Dans thermcell_flux '//descr
+         write(lunout,*) 'flux base ',f(igout)
+         write(lunout,*) 'lmax ',lmax(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) 'ig= ',igout
+         write(lunout,'(a3,4a14)') 'l','M','E','D','F'
+         write(lunout,'(i4,4e14.4)') (l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l) &
+     &    ,fm(igout,l+1),l=1,lm)
+
+
+      do l=lmax(igout)+1,klev
+          if (abs(entr(igout,l))+abs(detr(igout,l))+abs(fm(igout,l)).gt.0.) then
+          print*,'cas 1 : igout,l,lmax(igout)',igout,l,lmax(igout)
+          print*,'entr(igout,l)',entr(igout,l)
+          print*,'detr(igout,l)',detr(igout,l)
+          print*,'fm(igout,l)',fm(igout,l)
+          stop
+          endif
+      enddo
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_height.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_height.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_height.F90	(revision 984)
@@ -0,0 +1,125 @@
+      SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,  &
+     &           zw2,zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)                            
+
+!-----------------------------------------------------------------------------
+!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix
+!-----------------------------------------------------------------------------
+      IMPLICIT NONE
+
+      INTEGER ig,l
+      INTEGER ngrid,nlay
+      INTEGER lalim(ngrid),lmin(ngrid)
+      INTEGER lmix(ngrid)
+      REAL linter(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+      REAL zw2(ngrid,nlay+1)
+      REAL zlev(ngrid,nlay+1)
+
+      REAL wmax(ngrid)
+      INTEGER lmax(ngrid)
+      REAL zmax(ngrid)
+      REAL zmax0(ngrid)
+      REAL zmix(ngrid)
+
+      REAL zlevinter(ngrid)
+
+!calcul de la hauteur max du thermique
+      do ig=1,ngrid
+         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+             lmax(ig)=1
+             lmin(ig)=1
+             lalim(ig)=1
+         endif
+      enddo 
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+     &    -zlev(ig,lmax(ig)))
+!pour le cas ou on prend tjs lmin=1
+!       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+      enddo
+!
+! def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1) then
+! test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)  &
+     &        then
+!             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))  &
+     &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+!test
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+!            print*,'pb zmix>zmax'
+         endif
+      enddo
+!
+! calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,nlay
+            if (zmix(ig).ge.zlev(ig,l).and.  &
+     &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_init.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_init.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_init.F90	(revision 984)
@@ -0,0 +1,100 @@
+      SUBROUTINE thermcell_init(ngrid,nlay,ztv,zlev,  &
+     &                  lalim,lmin,alim_star,alim_star_tot,lev_out)
+
+!----------------------------------------------------------------------
+!thermcell_init: calcul du profil d alimentation du thermique
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+      INTEGER l,ig
+!arguments d entree
+      INTEGER ngrid,nlay
+      REAL ztv(ngrid,nlay)
+      REAL zlev(ngrid,nlay)
+!arguments de sortie
+      INTEGER lalim(ngrid)
+      INTEGER lmin(ngrid)
+      REAL alim_star(ngrid,nlay)
+      REAL alim_star_tot(ngrid)
+      integer lev_out                           ! niveau pour les print
+      
+!CR: ponderation entrainement des couches instables
+!def des alim_star tels que alim=f*alim_star      
+
+      do l=1,nlay
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+         enddo
+      enddo
+! determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lalim(ig)=1
+      enddo
+
+!on ne considere que les premieres couches instables
+      do l=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          ztv(ig,l+1).le.ztv(ig,l+2)) then
+               lalim(ig)=l+1
+            endif
+          enddo
+      enddo
+
+! determination du lmin: couche d ou provient le thermique
+
+      do ig=1,ngrid
+! FH initialisation de lmin a nlay plutot que 1.
+!        lmin(ig)=nlay
+         lmin(ig)=1
+      enddo
+      do l=nlay,2,-1
+         do ig=1,ngrid
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!
+! definition de l'entrainement des couches
+      do l=1,nlay-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
+!def possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
+     &                       *sqrt(zlev(ig,l+1)) 
+            endif
+         enddo
+      enddo
+      
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+!CRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,nlay
+                alim_star(ig,l)=0.
+            enddo
+            lmin(ig)=1
+         endif
+      enddo 
+! calcul de l alimentation totale
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+         enddo
+      enddo
+!
+! Calcul entrainement normalise
+      do l=1,nlay 
+         do ig=1,ngrid 
+            if (alim_star_tot(ig).gt.1.e-10) then
+               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+            endif
+         enddo
+      enddo
+       
+      return 
+      end  
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_main.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_main.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_main.F90	(revision 984)
@@ -0,0 +1,601 @@
+!
+! $Header$
+!
+      SUBROUTINE thermcell_main(ngrid,nlay,ptimestep  &
+     &                  ,pplay,pplev,pphi,debut  &
+     &                  ,pu,pv,pt,po  &
+     &                  ,pduadj,pdvadj,pdtadj,pdoadj  &
+     &                  ,fm0,entr0,zqla,lmax  &
+     &                  ,ratqscth,ratqsdiff,zqsatth  &
+     &                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+!=======================================================================
+!   Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu
+!   Version du 09.02.07
+!   Calcul du transport vertical dans la couche limite en presence
+!   de "thermiques" explicitement representes avec processus nuageux
+!
+!   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!
+!   le thermique est supposé homogène et dissipé par mélange avec
+!   son environnement. la longueur l_mix contrôle l'efficacité du
+!   mélange
+!
+!   Le calcul du transport des différentes espèces se fait en prenant
+!   en compte:
+!     1. un flux de masse montant
+!     2. un flux de masse descendant
+!     3. un entrainement
+!     4. un detrainement
+!
+!=======================================================================
+
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+!   arguments:
+!   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+!   local:
+!   ------
+
+!      integer,save :: igout=4259
+      integer,save :: igout=2928
+      integer,save :: lunout=6
+      integer,save :: lev_out=10
+
+      INTEGER ig,k,l,ll
+      real zsortie1d(klon)
+      INTEGER lmax(klon),lmin(klon),lalim(klon)
+      INTEGER lmix(klon)
+      real linter(klon)
+      real zmix(klon)
+      real zmax(klon),zw2(klon,klev+1),ztva(klon,klev)
+      real zmax_sec(klon)
+      real w_est(klon,klev+1)
+!on garde le zmax du pas de temps precedent
+      real zmax0(klon)
+      save zmax0
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real fraca(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+      common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real var
+      real vardiff
+      real ratqsdiff(klon,klev)
+      integer isplit,nsplit
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon)
+      real wmax_sec(klon)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real detr0(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+!niveau de condensation
+      real nivcon(klon)
+      real zcon(klon)
+      REAL CHI
+      real zcon2(klon)
+      real pcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real alim_star(klon,klev)
+      real f(klon), f0(klon)
+      save f0
+      real zlevinter(klon)
+      logical debut
+       real seuil
+
+!
+
+      character*2 str2
+      character*10 str10
+
+      EXTERNAL SCOPY
+!
+
+!-----------------------------------------------------------------------
+!   initialisation:
+!   ---------------
+!
+
+      seuil=0.25
+
+      if (lev_out.ge.1) print*,'thermcell_main V4'
+
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!
+!Initialisation
+!
+      do ig=1,klon      
+      if ((debut).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
+            f0(ig)=1.e-5
+            zmax0(ig)=40.
+      endif
+      enddo 
+
+
+
+!-----------------------------------------------------------------------
+! Calcul de T,q,ql a partir de Tl et qT dans l environnement
+!   --------------------------------------------------------------------
+!
+      CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
+       
+      if (lev_out.ge.1) print*,'thermcell_main apres thermcell_env'
+
+!------------------------------------------------------------------------
+!                       --------------------
+!
+!
+!                       + + + + + + + + + + +
+!
+!
+!  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!  wh,wt,wo ...
+!
+!                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!
+!
+!                       --------------------   zlev(1)
+!                       \\\\\\\\\\\\\\\\\\\\
+!
+!
+
+!-----------------------------------------------------------------------
+!   Calcul des altitudes des couches
+!-----------------------------------------------------------------------
+
+      do l=2,nlay
+         zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG
+      enddo
+         zlev(:,1)=0.
+         zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG
+      do l=1,nlay
+         zlay(:,l)=pphi(:,l)/RG
+      enddo
+!calcul de l epaisseur des couches
+      do l=1,nlay
+         deltaz(:,l)=zlev(:,l+1)-zlev(:,l)
+      enddo
+
+!     print*,'2 OK convect8'
+!-----------------------------------------------------------------------
+!   Calcul des densites
+!-----------------------------------------------------------------------
+
+      do l=1,nlay
+         rho(:,l)=pplay(:,l)/(zpspsk(:,l)*RD*ztv(:,l))
+      enddo
+
+      do l=2,nlay
+         rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1))
+      enddo
+
+!calcul de la masse
+      do l=1,nlay
+         masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG
+      enddo
+
+      if (lev_out.ge.1) print*,'thermcell_main apres initialisation'
+
+!------------------------------------------------------------------
+!
+!             /|\
+!    --------  |  F_k+1 -------   
+!                              ----> D_k
+!             /|\              <---- E_k , A_k
+!    --------  |  F_k --------- 
+!                              ----> D_k-1
+!                              <---- E_k-1 , A_k-1
+!
+!
+!
+!
+!
+!    ---------------------------
+!
+!    ----- F_lmax+1=0 ----------         \
+!            lmax     (zmax)              |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |  E
+!    ---------------------------          |  D
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------  \       |
+!            lalim                 |      |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!                                  | A    |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!    lmin  (=1 pour le moment)     |      |
+!    ----- F_lmin=0 ------------  /      /
+!
+!    ---------------------------
+!    //////////////////////////
+!
+!
+!=============================================================================
+!  Calculs initiaux ne faisant pas intervenir les changements de phase
+!=============================================================================
+
+!------------------------------------------------------------------
+!  1. alim_star est le profil vertical de l'alimentation à la base du
+!     panache thermique, calculé à partir de la flotabilité de l'air sec
+!  2. lmin et lalim sont les indices inferieurs et superieurs de alim_star
+!------------------------------------------------------------------
+!
+      entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0.
+      CALL thermcell_init(ngrid,nlay,ztv,zlev,  &
+     &                    lalim,lmin,alim_star,alim_star_tot,lev_out)
+
+call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lmin  ')
+call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lalim ')
+
+
+      if (lev_out.ge.1) print*,'thermcell_main apres thermcell_init'
+      if (lev_out.ge.10) then
+         write(lunout,*) 'Dans thermcell_main 1'
+         write(lunout,*) 'lmin ',lmin(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) ' ig l alim_star thetav'
+         write(lunout,'(i6,i4,2e15.5)') (igout,l,alim_star(igout,l) &
+     &   ,ztv(igout,l),l=1,lalim(igout)+4)
+      endif
+
+!-----------------------------------------------------------------------------
+!  3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un
+!     panache sec conservatif (e=d=0) alimente selon alim_star 
+!     Il s'agit d'un calcul de type CAPE
+!     zmax_sec est utilisé pour déterminer la géométrie du thermique.
+!------------------------------------------------------------------------------
+!
+      CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
+
+call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
+call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
+
+      if (lev_out.ge.1) print*,'thermcell_main apres thermcell_dry'
+      if (lev_out.ge.10) then
+         write(lunout,*) 'Dans thermcell_main 1b'
+         write(lunout,*) 'lmin ',lmin(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) &
+     &    ,l=1,lalim(igout)+4)
+      endif
+
+
+
+!---------------------------------------------------------------------------------
+!calcul du melange et des variables dans le thermique
+!--------------------------------------------------------------------------------
+!
+      CALL thermcell_plume(ngrid,nlay,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,  &
+     &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,zqsatth,lmix,linter,lev_out)
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
+
+      if (lev_out.ge.1) print*,'thermcell_main apres thermcell_plume'
+      if (lev_out.ge.10) then
+         write(lunout,*) 'Dans thermcell_main 2'
+         write(lunout,*) 'lmin ',lmin(igout)
+         write(lunout,*) 'lalim ',lalim(igout)
+         write(lunout,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
+     &    ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
+      endif
+
+!-------------------------------------------------------------------------------
+! Calcul des caracteristiques du thermique:zmax,zmix,wmax
+!-------------------------------------------------------------------------------
+!
+      CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2,  &
+     &           zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)
+
+
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
+
+      if (lev_out.ge.1) print*,'thermcell_main apres thermcell_height'
+
+!-------------------------------------------------------------------------------
+! Fermeture,determination de f
+!-------------------------------------------------------------------------------
+
+      CALL thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,zmax_sec,wmax_sec,zmax,wmax,f,f0,lev_out)
+
+      if(lev_out.ge.1)print*,'thermcell_closure apres thermcell_closure'
+
+!-------------------------------------------------------------------------------
+!deduction des flux
+!-------------------------------------------------------------------------------
+
+      CALL thermcell_flux(ngrid,nlay,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,zmax,lev_out,lunout,igout)
+
+      if (lev_out.ge.1) print*,'thermcell_main apres thermcell_flux'
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax  ')
+
+!c------------------------------------------------------------------
+!   calcul du transport vertical
+!------------------------------------------------------------------
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+         detr0=detr
+      endif
+
+      call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse,  &
+     &                    zthl,zdthladj,zta,lev_out)
+      call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse,  &
+     &                   po,pdoadj,zoa,lev_out)
+
+      if (1.eq.0) then
+
+! Calcul du transport de V tenant compte d'echange par gradient
+! de pression horizontal avec l'environnement
+
+         call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,fraca,zmax  &
+     &    ,zu,zv,pduadj,pdvadj,zua,zva,lev_out)
+      else
+
+! calcul purement conservatif pour le transport de V
+         call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,zu,pduadj,zua,lev_out)
+         call thermcell_dq(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,zv,pdvadj,zva,lev_out)
+      endif
+
+!     print*,'13 OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+      print*,'14 OK convect8'
+!------------------------------------------------------------------
+!   Calculs de diagnostiques pour les sorties
+!------------------------------------------------------------------
+!calcul de fraca pour les sorties
+      
+      if (sorties) then
+      do ig=1,klon
+         fraca(ig,1)=0.
+      enddo
+      do l=2,nlay
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+     
+      print*,'14a OK convect8'
+! calcul du niveau de condensation
+! initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0.
+         zcon(ig)=0.
+      enddo 
+!nouveau calcul
+      do ig=1,ngrid
+      CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1))
+      pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI
+      enddo
+      do k=1,nlay
+         do ig=1,ngrid
+         if ((pcon(ig).le.pplay(ig,k))  &
+     &      .and.(pcon(ig).gt.pplay(ig,k+1))) then
+            zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100.
+         endif
+         enddo
+      enddo
+      print*,'14b OK convect8'
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+         enddo
+      enddo
+      print*,'14c OK convect8'
+!calcul des moments
+!initialisation
+      do l=1,nlay
+         do ig=1,ngrid
+            q2(ig,l)=0.
+            wth2(ig,l)=0.
+            wth3(ig,l)=0.
+            ratqscth(ig,l)=0.
+            ratqsdiff(ig,l)=0.
+         enddo
+      enddo      
+      print*,'14d OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            wth2(ig,l)=zf2*(zw2(ig,l))**2
+!           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))  &
+     &                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+!test: on calcul q2/po=ratqsc
+            ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.))
+         enddo
+      enddo
+!calcul du ratqscdiff
+      print*,'14e OK convect8'
+      var=0.
+      vardiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lalim(ig)
+            var=var+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      print*,'14f OK convect8'
+      do ig=1,ngrid
+          do l=1,lalim(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+          vardiff=vardiff+alim_star(ig,l)  &
+     &           *(zqta(ig,l)*1000.-var)**2
+!         ratqsdiff=ratqsdiff+alim_star(ig,l)*
+!     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      print*,'14g OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+            ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.)   
+!           write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+         enddo
+      enddo 
+!--------------------------------------------------------------------    
+!
+!ecriture des fichiers sortie
+!     print*,'15 OK convect8'
+
+      isplit=isplit+1       
+
+
+#ifdef und
+      if (lev_out.ge.1) print*,'thermcell_main sorties 1D'
+#include "thermcell_out1d.h"
+#endif
+
+
+! #define troisD
+      if (lev_out.ge.1) print*,'thermcell_main sorties 3D'
+#ifdef troisD
+#include "thermcell_out3d.h"
+#endif
+
+      endif
+
+      if (lev_out.ge.1) print*,'thermcell_main FIN  OK'
+
+      return
+      end
+
+!-----------------------------------------------------------------------------
+
+      subroutine test_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment)
+
+      integer klon,klev
+      real pplev(klon,klev+1),pplay(klon,klev)
+      real ztv(klon,klev)
+      real po(klon,klev)
+      real ztva(klon,klev)
+      real zqla(klon,klev)
+      real f_star(klon,klev)
+      real zw2(klon,klev)
+      integer long(klon)
+      real seuil
+      character*21 comment
+
+      print*,'TEST ',comment
+!  test sur la hauteur des thermiques ...
+         do i=1,klon
+            if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then
+               print*,'WARNING ',comment,' au point ',i,' K= ',long(i)
+               print*,'  K  P(MB)  THV(K)     Qenv(g/kg)THVA        QLA(g/kg)   F*        W2'
+               do k=1,klev
+                  write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k)
+               enddo
+!              stop
+            endif
+         enddo
+
+
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_old.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_old.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_old.F	(revision 984)
@@ -0,0 +1,6083 @@
+      SUBROUTINE thermcell_2002(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmax(klon,klev+1),lmaxa(klon),lmix(klon)
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon,klev),wmaxa(klon)
+
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+            wa(ig,k,k)=0.
+            wa(ig,k,k+1)=2.*RG*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig,k+1)
+     s      *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+         do l=k+1,nlay-1
+            do ig=1,ngrid
+               wa(ig,k,l+1)=wa(ig,k,l)+
+     s         2.*RG*(ztv(ig,k)-ztv(ig,l))/ztv(ig,l)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+            enddo
+         enddo
+         do ig=1,ngrid
+            wa(ig,k,nlay+1)=0.
+         enddo
+      enddo
+
+c     print*,'4 OK convect8'
+c Calcul de la couche correspondant a la hauteur du thermique
+      do k=1,nlay-1
+         do ig=1,ngrid
+            lmax(ig,k)=k
+         enddo
+         do l=nlay,k+1,-1
+            do ig=1,ngrid
+               if(wa(ig,k,l).le.1.e-10) lmax(ig,k)=l-1
+            enddo
+         enddo
+      enddo
+
+c     print*,'5 OK convect8'
+c   Calcule du w max du thermique
+      do k=1,nlay
+      do ig=1,ngrid
+         wmax(ig,k)=0.
+      enddo
+      enddo
+
+      do k=1,nlay-1
+         do l=k,nlay
+            do ig=1,ngrid
+               if (l.le.lmax(ig,k)) then
+                  wa(ig,k,l)=sqrt(wa(ig,k,l))
+                  wmax(ig,k)=max(wmax(ig,k),wa(ig,k,l))
+               else
+                  wa(ig,k,l)=0.
+               endif
+            enddo
+         enddo
+      enddo
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+             pu_therm(ig,k)=sqrt(wmax(ig,k))
+             pv_therm(ig,k)=sqrt(wmax(ig,k))
+         enddo
+      enddo
+
+c     print*,'6 OK convect8'
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+      enddo
+c     print*,'LMAX LMAX LMAX '
+      do k=1,nlay-1
+         do  ig=1,ngrid
+            zmax(ig)=max(zmax(ig),zlev(ig,lmax(ig,k))-zlev(ig,k))
+         enddo
+c     print*,k,lmax(1,k)
+      enddo
+c     print*,'ZMAX ZMAX ZMAX ',zmax
+c      call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX      ')
+
+c   Calcul de l'entrainement.
+c   Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur
+c   de la couche d'alimentation en partant du principe que la vitesse
+c   maximum dans l'ascendance est la vitesse d'entrainement horizontale.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzz=rho(ig,k)*wmax(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+     s    /(zmax(ig)*r_aspect)
+            if(w2di.eq.2) then
+               entr(ig,k)=entr(ig,k)+
+     s         ptimestep*(zzz-entr(ig,k))/float(tho)
+            else
+               entr(ig,k)=zzz
+            endif
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+
+      do l=1,nlay-2
+         do ig=1,ngrid
+c           if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then
+c         print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1)
+            if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)
+     s       .and.entr(ig,l).gt.1.e-10) then
+c        print*,'COUCOU cas 1'
+c   Initialisation de l'ascendance
+c              lmix(ig)=1
+               ztva(ig,l)=ztv(ig,l)
+               fmc(ig,l)=0.
+               fmc(ig,l+1)=entr(ig,l)
+               zw2(ig,l)=0.
+c     if (.not.ztv(ig,l+1).gt.150.) then
+c     print*,'ig,l+1,ztv(ig,l+1)'
+c     print*, ig,l+1,ztv(ig,l+1)
+c        stop'dans thermiques'
+c     endif
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+               larg_detr(ig,l)=0.
+            else if (zw2(ig,l).ge.1.e-10.and.
+     .               fmc(ig,l)+entr(ig,l).gt.1.e-10) then
+c   Incrementation...
+               fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+c     if (.not.fmc(ig,l+1).gt.1.e-15) then
+c     print*,'ig,l+1,fmc(ig,l+1)'
+c     print*, ig,l+1,fmc(ig,l+1)
+c     print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1)
+c     print*,'W2 ',(zw2(ig,ll),ll=1,klev+1)
+c     print*,'Tv ',(ztv(ig,ll),ll=1,klev)
+c     print*,'Entr ',(entr(ig,ll),ll=1,klev)
+c        stop'dans thermiques'
+c     endif
+               ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))
+     s          /fmc(ig,l+1)
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+               zw2(ig,l+1)=zw2(ig,l)*(fmc(ig,l)/fmc(ig,l+1))**2+
+     s         2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+            if (zw2(ig,l+1).lt.0.) then
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+c        print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig)
+         enddo
+      enddo
+
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+               if(l.gt.lmix(ig)) then
+                  xxx(ig,l)=(lmaxa(ig)+1.-l) / (lmaxa(ig)+1.-lmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fraca(ig,lmix(ig))
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)**2
+           endif
+               endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo
+
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c     print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c     print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c     print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE thermcell_cld(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev,debut
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0,zqla,lmax
+     s                  ,zmax_sec,wmax_sec,zw_sec,lmix_sec
+     s                  ,ratqscth,ratqsdiff
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon)
+      real alpha
+      save alpha
+      data alpha/1./
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+      real zmax_sec(klon)
+      real zmax_sec2(klon)
+      real zw_sec(klon,klev+1)
+      INTEGER lmix_sec(klon)
+      real w_est(klon,klev+1)
+con garde le zmax du pas de temps precedent
+      real zmax0(klon)
+      save zmax0
+      real zmix0(klon)
+      save zmix0 
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+      real dtheta(klon,klev)
+      common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real sum
+      real sumdiff
+      real ratqsdiff(klon,klev)
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wmax_sec(klon)
+      real wmax_sec2(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real massetot(klon,klev)
+      real detr0(klon,klev)
+      real alim0(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+cCR niveau de condensation
+      real nivcon(klon)
+      real zcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+      PARAMETER (DDT0=.01)
+
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real entr_star_tot(klon)
+      real detr_star_tot(klon)
+      real alim_star(klon,klev)
+      real alim(klon,klev)
+      real nu(klon,klev)
+      real nu_e(klon,klev)
+      real nu_min
+      real nu_max
+      real nu_r
+      real f(klon), f0(klon)
+      save f0
+      real f_old
+      real zlevinter(klon)
+      logical first
+c      data first /.false./
+c      save first
+      logical nuage
+c      save nuage
+      logical boucle
+      logical therm
+      logical debut
+      logical rale
+      integer test(klon)
+      integer signe_zw2
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c
+
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.false.
+c     print*,'NOUVEAU DETR PLUIE '
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+cinitialisations de zqsat
+      DO ll=1,nlay
+         DO ig=1,ngrid
+            zqsat(ig,ll)=0.
+            zqsatth(ig,ll)=0.
+         ENDDO
+      ENDDO
+c
+con met le first a true pour le premier passage de la journée
+      do ig=1,klon
+            test(ig)=0
+      enddo
+      if (debut) then
+         do ig=1,klon
+            test(ig)=1
+            f0(ig)=0.
+            zmax0(ig)=0.
+         enddo
+      endif
+      do ig=1,klon      
+         if ((.not.debut).and.(f0(ig).lt.1.e-10)) then
+            test(ig)=1
+         endif
+      enddo 
+c     do ig=1,klon
+c        print*,'test(ig)',test(ig),zmax0(ig)
+c     enddo
+      nuage=.false.
+c-----------------------------------------------------------------------
+cAM Calcul de T,q,ql a partir de Tl et qT
+c   ---------------------------------------------------
+c
+c Pr Tprec=Tl calcul de qsat 
+c Si qsat>qT T=Tl, q=qT
+c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+c On cherche DDT < DDT0
+c
+c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+c
+c
+       DO ll=1,nlay
+c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 1.e-10)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig).and.(1.eq.1)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+c            write(18,*),'DT0=',DT
+c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (abs(DT).gt.DDT0)
+c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              if (denom.lt.1.e-10) then
+                  print*,'pb denom'
+              endif
+              DT=num/denom
+            enddo
+c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+con ecrit zqsat 
+            zqsat(ig,ll)=qsatbef(ig)     
+         EndDO
+       EndDO
+cAM fin
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c     print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+             zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
+c            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+c            zo(ig,l)=po(ig,l)
+c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+cAM attention zh est maintenant le profil de T et plus le profil de theta !
+c
+c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))
+     s           -zl(ig,l))
+cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+c            
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+ccalcul de deltaz
+      do l=1,nlay
+         do ig=1,ngrid
+            deltaz(ig,l)=zlev(ig,l+1)-zlev(ig,l)
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+cCr:ajout:calcul de la masse
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des alim_star tels que alim=f*alim_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+            alim(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+c
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.lt.lentr(ig)) then
+cdef possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)
+c     s                       *(zlev(ig,l+1)-zlev(ig,l))
+     s                       *sqrt(zlev(ig,l+1))
+c             alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.) 
+            endif
+         enddo
+      enddo
+      
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+c         if (lmin(ig).gt.1) then
+cCRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,klev
+                alim_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+         entr_star_tot(ig)=0.
+         detr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
+         enddo
+      enddo
+c
+c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (alim_star_tot(ig).gt.1.e-10) then
+c         do l=1,lentr(ig)
+          do l=1,klev
+cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+         enddo
+         endif
+      enddo
+       
+c     print*,'fin calcul alim_star'
+
+cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+cn     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+      nu_min=l_mix
+      nu_max=1000.
+c      do ig=1,ngrid
+c      nu_max=wmax_sec(ig)
+c      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            nu(ig,k)=0.
+            nu_e(ig,k)=0.
+         enddo
+      enddo
+cCalcul de l'excès de température du à la diffusion turbulente
+      do ig=1,ngrid
+         do l=1,klev
+            dtheta(ig,l)=0.
+         enddo
+       enddo
+      do ig=1,ngrid
+         do l=1,lentr(ig)-1
+      dtheta(ig,l)=sqrt(10.*0.4*zlev(ig,l+1)**2*1.
+     s          *((ztv(ig,l+1)-ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2)
+         enddo
+       enddo
+c      do l=1,nlay-2
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.alim_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+cAM
+ctest:on rajoute un excès de T dans couche alim
+c               ztla(ig,l)=zthl(ig,l)+dtheta(ig,l)
+               ztla(ig,l)=zthl(ig,l) 
+ctest: on rajoute un excès de q dans la couche alim
+c               zqta(ig,l)=po(ig,l)+0.001
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+cAM
+               f_star(ig,l+1)=alim_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+               larg_detr(ig,l)=0.
+c     print*,'coucou boucle 1'
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+c     print*,'coucou boucle 2'
+cestimation du detrainement a partir de la geometrie du pas precedent
+      if ((test(ig).eq.1).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
+                  detr_star(ig,l)=0.
+                  entr_star(ig,l)=0.
+c     print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig)
+             else
+c     print*,'coucou debut detr'
+ctests sur la definition du detr
+        if (zqla(ig,l-1).gt.1.e-10) then
+           nuage=.true.
+        endif 
+
+             w_est(ig,l+1)=zw2(ig,l)*
+     s                   ((f_star(ig,l))**2)
+     s                   /(f_star(ig,l)+alim_star(ig,l))**2+
+     s                   2.*RG*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l)
+     s                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+      if (l.gt.2) then
+             if ((w_est(ig,l+1).gt.w_est(ig,l)).and.
+     s           (zlev(ig,l+1).lt.zmax_sec(ig)).and.
+     s            (zqla(ig,l-1).lt.1.e-10)) then 
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)
+     s                *sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)*zlev(ig,l+1))
+     s       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)*zlev(ig,l)))
+     s       /(r_aspect*zmax_sec(ig)))
+             else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.
+     s                (zqla(ig,l-1).lt.1.e-10)) then
+       detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))
+     s /(rhobarz(ig,lmix(ig))*wmaxa(ig))*
+     s (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))
+     s *((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))
+     s **2.
+     s -rhobarz(ig,l)*sqrt(w_est(ig,l))
+     s *((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))
+     s **2.)
+             else
+       detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)
+     s                *(zlev(ig,l+1)-zlev(ig,l))
+             
+             endif
+        else
+        detr_star(ig,l)=0.
+        endif
+       
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if (nuage) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         else
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         endif
+
+             if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+c              entr_star(ig,l)=0.
+              endif
+
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+c                 detr_star(ig,l)=0.
+             endif  
+
+c           print*,'ok detr_star'
+      endif
+cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+     s                      -detr_star(ig,l)
+ctest
+c             if (f_star(ig,l+1).lt.0.) then
+c                f_star(ig,l+1)=0.
+c                entr_star(ig,l)=0.
+c                detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)
+c             endif
+ctest sur le signe de f_star
+       if (f_star(ig,l+1).gt.1.e-10) then 
+c                 then
+ctest
+c         if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then
+cAM on melange Tl et qt du thermique
+con rajoute un excès de T dans la couche alim
+c               if (l.lt.lentr(ig)) then
+c           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+c     s     (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l)))
+c     s     /(f_star(ig,l+1)+detr_star(ig,l))
+c               else
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+     s                    (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))
+     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c     s                    /(f_star(ig,l+1)) 
+c               endif
+con rajoute un excès de q dans la couche alim
+c               if (l.lt.lentr(ig)) then
+c               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+c     s           (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001))
+c     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c               else
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+     s                    (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))
+     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c     s                   /(f_star(ig,l+1))
+c               endif
+cAM on en deduit thetav et ql du thermique
+cCR test
+c               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)  
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+             Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 1.e-10)
+
+           if (Zsat(ig).and.(1.eq.1)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+c             write(17,*)'DT0=',DT
+              do while (abs(DT).gt.DDT0)
+c                 print*,'aie'
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 if (denom.lt.1.e-10) then
+                    print*,'pb denom'
+                 endif
+                 DT=num/denom
+c                 write(17,*)'DT=',DT
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+              zqla(ig,l) = max(0.,qlbef) 
+c              zqla(ig,l)=0.
+             endif
+c             zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+c      
+c on ecrit de maniere conservative (sat ou non)
+c          T = Tl +Lv/Cp ql
+cCR rq utilisation de humidite specifique ou rapport de melange?
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+con rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+c           if (l.lt.lentr(ig)) then
+c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+c     s              -zqla(ig,l))-zqla(ig,l)) + 0.1
+c           else
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+     s              -zqla(ig,l))-zqla(ig,l))
+c           endif
+c           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+c     s                 /(1.-retv*zqla(ig,l))
+c           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+c     s                 /(1.-retv*zqta(ig,l))
+c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+c       write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l))
+con ecrit zqsat 
+           zqsatth(ig,l)=qsatbef(ig)  
+c        enddo
+c        DO ig=1,ngrid
+c           if (zw2(ig,l).ge.1.e-10.and.
+c     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+c
+c            if (f_star(ig,l+1).gt.1.e-10) then
+            zw2(ig,l+1)=zw2(ig,l)*
+c     s                  ((f_star(ig,l)-detr_star(ig,l))**2)
+c     s                  /f_star(ig,l+1)**2+
+     s                   ((f_star(ig,l))**2)
+     s                   /(f_star(ig,l+1)+detr_star(ig,l))**2+
+c     s                    /(f_star(ig,l+1))**2+           
+     s                   2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                   *(zlev(ig,l+1)-zlev(ig,l))
+c     s                   *(f_star(ig,l)/f_star(ig,l+1))**2
+
+            endif
+        endif
+c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+c              print*,'linter=',linter(ig)
+c          else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then
+c               linter(ig)=l+1
+c               print*,'linter=l',zw2(ig,l),zw2(ig,l+1)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+c            wa_moy(ig,l+1)=zw2(ig,l+1) 
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+cpour le cas ou on prend tjs lmin=1
+c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+       write(11,*)'ig,lmax,linter',ig,lmax(ig),linter(ig)
+       write(12,*)'ig,zlevinter,zmax',ig,zmax(ig),zlevinter(ig)
+      enddo
+
+cCalcul de zmax_sec et wmax_sec
+      call fermeture_seche(ngrid,nlay
+     s                  ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk
+     s                  ,alim,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect
+     s                  ,zmax_sec2,wmax_sec2)
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+c en lmax f=d-e
+      do ig=1,ngrid
+c      entr_star(ig,lmax(ig))=0.
+c      f_star(ig,lmax(ig)+1)=0.
+c      detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig))
+c     s                       +alim_star(ig,lmax(ig))
+      enddo
+c
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+ccalcul de entr_star_tot
+      do ig=1,ngrid
+         do k=1,lmix(ig)
+            entr_star_tot(ig)=entr_star_tot(ig)
+c     s                        +entr_star(ig,k)
+     s                        +alim_star(ig,k)
+c     s                        -detr_star(ig,k)
+            detr_star_tot(ig)=detr_star_tot(ig)
+c     s                        +alim_star(ig,k)
+     s                        -detr_star(ig,k)
+     s                        +entr_star(ig,k)
+         enddo
+      enddo
+      
+      do ig=1,ngrid
+         if (alim_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else   
+c             do k=lmin(ig),lentr(ig)
+             do k=1,lentr(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then 
+             f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect
+     s             *alim_star2(ig))
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/
+     s                     zmax_sec(ig))*wmax_sec(ig))
+             else
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig))
+            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/
+     s                     zmax(ig))*wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+      enddo
+      print*,'apres fermeture'
+c Calcul de l'entrainement
+         do ig=1,ngrid 
+            do k=1,klev
+            alim(ig,k)=f(ig)*alim_star(ig,k)
+         enddo
+      enddo
+cCR:test pour entrainer moins que la masse
+c       do ig=1,ngrid
+c          do l=1,lentr(ig)
+c             if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+c                alim(ig,l+1)=alim(ig,l+1)+alim(ig,l)
+c     s                       -0.9*masse(ig,l)/ptimestep
+c                alim(ig,l)=0.9*masse(ig,l)/ptimestep
+c             endif
+c          enddo
+c       enddo
+c calcul du détrainement
+         do ig=1,klon
+             do k=1,klev
+            detr(ig,k)=f(ig)*detr_star(ig,k)
+            if (detr(ig,k).lt.0.) then
+c               print*,'detr1<0!!!'
+            endif
+            enddo
+            do k=1,klev
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+            if (entr(ig,k).lt.0.) then
+c               print*,'entr1<0!!!'
+            endif
+         enddo
+      enddo
+c
+c       do ig=1,ngrid
+c          do l=1,klev
+c          if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt.
+c     s          (masse(ig,l))) then  
+c      print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a='
+c     s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l)
+c      endif
+c      enddo
+c      enddo
+c Calcul des flux
+
+      do ig=1,ngrid
+         do l=1,lmax(ig)
+c         do l=1,klev
+c             fmc(ig,l+1)=f(ig)*f_star(ig,l+1)
+            fmc(ig,l+1)=fmc(ig,l)+alim(ig,l)+entr(ig,l)-detr(ig,l)
+c        print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+c     s  'f+1=',fmc(ig,l+1)
+          if (fmc(ig,l+1).lt.0.) then
+               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+               fmc(ig,l+1)=fmc(ig,l)
+               detr(ig,l)=alim(ig,l)+entr(ig,l)
+c               fmc(ig,l+1)=0.
+c               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+            endif
+c       if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+c          f_old=fmc(ig,l+1)
+c          fmc(ig,l+1)=fmc(ig,l)
+c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+c       endif
+       
+c        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+c          f_old=fmc(ig,l+1)
+c          fmc(ig,l+1)=fmc(ig,l)
+c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l)
+c       endif
+crajout du test sur alpha croissant
+cif test
+c       if (1.eq.0) then
+
+       if (l.eq.klev) then
+          print*,'THERMCELL PB ig=',ig,'   l=',l
+          stop
+       endif
+!       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+!     s     (l.ge.lentr(ig)).and.
+       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+     s         (l.ge.lentr(ig)) ) then
+          if ( ((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.
+     s     (fmc(ig,l)/(rhobarz(ig,l)*zw2(ig,l))))) then
+           f_old=fmc(ig,l+1)
+           fmc(ig,l+1)=fmc(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)
+     s                          /(rhobarz(ig,l)*zw2(ig,l))
+           detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) 
+c           detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.)
+c           entr(ig,l)=0.4*detr(ig,l)
+c           entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l)
+        endif
+        endif
+        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=fmc(ig,l)
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+       endif
+       if (detr(ig,l).gt.fmc(ig,l)) then
+               detr(ig,l)=fmc(ig,l)
+               entr(ig,l)=fmc(ig,l+1)-alim(ig,l)
+        endif
+       if (fmc(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fmc(ig,l+1)
+               fmc(ig,l+1)=0.
+               print*,'fmc2<0',l+1,lmax(ig)
+            endif
+            
+ctest pour ne pas avoir f=0 et d=e/=0
+c       if (fmc(ig,l+1).lt.1.e-10) then
+c          detr(ig,l+1)=0.
+c          entr(ig,l+1)=0.
+c          zqla(ig,l+1)=0.
+c          zw2(ig,l+1)=0.
+c          lmax(ig)=l+1
+c          zmax(ig)=zlev(ig,lmax(ig))
+c       endif 
+        if (zw2(ig,l+1).gt.1.e-10) then
+       if ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.
+     s      1.)) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=rhobarz(ig,l+1)*zw2(ig,l+1)
+          zw2(ig,l+1)=0.
+          zqla(ig,l+1)=0.
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+         lmax(ig)=l+1
+          zmax(ig)=zlev(ig,lmax(ig))
+          print*,'alpha>1',l+1,lmax(ig)
+       endif
+        endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cendif test
+c      endif
+      enddo
+      enddo
+      do ig=1,ngrid
+c         if (fmc(ig,lmax(ig)+1).ne.0.) then
+         fmc(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fmc(ig,lmax(ig))+entr(ig,lmax(ig))
+     s                     +alim(ig,lmax(ig))
+c         endif
+      enddo
+ctest sur le signe de fmc
+       do ig=1,ngrid
+         do l=1,klev+1
+            if (fmc(ig,l).lt.0.) then
+         print*,'fm1<0!!!','ig=',ig,'l=',l,'a=',alim(ig,l-1),'e='
+     s ,entr(ig,l-1),'f=',fmc(ig,l-1),'d=',detr(ig,l-1),'f+1=',fmc(ig,l)
+            endif
+         enddo
+       enddo
+ctest de verification
+      do ig=1,ngrid
+       do l=1,lmax(ig)
+       if ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+detr(ig,l)))
+     s           .gt.1.e-4) then
+c      print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+c     s  'f+1=',fmc(ig,l+1)
+       endif
+       if (detr(ig,l).lt.0.) then
+          print*,'detrdemi<0!!!'
+       endif
+         enddo
+      enddo
+c
+cRC
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+ctest
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+      do ig=1,klon
+         zmix0(ig)=zmix(ig)
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+cne devrait pas arriver!!!!!
+      do ig=1,ngrid
+       do l=1,klev
+          if (detr(ig,l).gt.(fmc(ig,l)+alim(ig,l))+entr(ig,l)) then
+             print*,'detr2>fmc2!!!','ig=',ig,'l=',l,'d=',detr(ig,l),
+     s             'f=',fmc(ig,l),'lmax=',lmax(ig)
+c             detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l)
+c             entr(ig,l)=0.
+c             fmc(ig,l+1)=0.
+c             zw2(ig,l+1)=0.     
+c             zqla(ig,l+1)=0.
+           print*,'pb!fm=0 et f_star>0',l,lmax(ig)        
+c             lmax(ig)=l
+          endif
+       enddo
+      enddo
+      do ig=1,ngrid
+         do l=lmax(ig)+1,klev+1
+c            fmc(ig,l)=0.
+c            detr(ig,l)=0.
+c            entr(ig,l)=0.
+c            zw2(ig,l)=0.
+c            zqla(ig,l)=0.
+         enddo
+      enddo
+
+cCalcul du detrainement lors du premier passage
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+         endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   cal1cul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          if (test(ig).eq.1) then
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+          endif
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                    xxx(ig,l)=(lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+      print*,'fin calcul fraca'
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              if (test(ig).eq.1) then
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (alim(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+              endif
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay+1
+         do ig=1,ngrid
+            if (test(ig).eq.0) then
+              fm(ig,l)=fmc(ig,l)
+            endif
+         enddo
+      enddo 
+   
+cfin du first
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+      print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+     s         ,fm(ig,l+1)*ptimestep
+     s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if((alim(ig,l)+entr(ig,l))*ptimestep.gt.masse(ig,l)) then
+      print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+     s         ,(entr(ig,l)+alim(ig,l))*ptimestep
+     s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.alim(ig,l).ge.0..or..not.alim(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+cCR:test:on ne change pas la def du entr mais la def du fm
+       do l=1,nlay
+         do ig=1,ngrid
+            if (test(ig).eq.1) then
+            detr(ig,l)=fm(ig,l)+alim(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+alim(ig,l)
+                detr(ig,l)=0.
+c                write(11,*)'l,ig,entr',l,ig,entr(ig,l)
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+            endif
+         enddo
+      enddo
+cRC
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(alim+entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=alim+entr
+         detr0=detr
+         alim0=alim
+c         zoa=zqta
+c         entr0=alim
+      endif
+
+      if (1.eq.1) then
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zh,zdhadj,zha)
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,
+     .                    zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,
+     .                   po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+cCalcul des moments
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+c            zf2=zf/(1.-zf)
+c            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+c            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+c         enddo
+c      enddo
+
+
+
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+ccalcul de fraca pour les sorties
+      do l=2,klev
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+c CR calcul du niveau de condensation
+c initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0.
+         zcon(ig)=0.
+      enddo 
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+c            if (zcon(ig).gt.1.e-10) then
+c               nuage=.true.
+c            else 
+c               nuage=.false.
+c            endif
+         enddo
+      enddo
+      
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            wth2(ig,l)=zf2*(zw2(ig,l))**2
+c           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))
+     s                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+ctest: on calcul q2/po=ratqsc
+c            if (nuage) then
+            ratqscth(ig,l)=sqrt(q2(ig,l))/(po(ig,l)*1000.)
+c            else
+c            ratqscth(ig,l)=0.
+c            endif
+         enddo
+      enddo
+ccalcul du ratqscdiff
+      sum=0.
+      sumdiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lentr(ig)
+            sum=sum+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      do ig=1,ngrid
+          do l=1,lentr(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+       sumdiff=sumdiff+alim_star(ig,l)
+     s           *(zqta(ig,l)*1000.-sum)**2
+c      ratqsdiff=ratqsdiff+alim_star(ig,l)*
+c     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      do l=1,klev
+      do ig=1,ngrid
+      ratqsdiff(ig,l)=sqrt(sumdiff)/(po(ig,l)*1000.)   
+c      write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+      enddo
+      enddo     
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1       
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+c         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+c         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+c         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+c         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+c         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+c         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,w_est,'w_est      ','w_est      ')
+con sort les moments
+         call wrgradsfi(1,nlay,thetath2,'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2,'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3,'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2,'q2       ','q2       ')
+         call wrgradsfi(1,nlay,dtheta,'dT       ','dT       ')
+c
+         call wrgradsfi(1,nlay,zw_sec,'zw_sec       ','zw_sec       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+         call wrgradsfi(1,nlay,nu,'nu       ','nu       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa,'zoa        ','zoa        ')
+c         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+c         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',
+     s        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz,'deltaz      ','deltaz      ')
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  ,'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    ,'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    ,'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    ,'alim_star   ','alim_star   ')
+      call wrgradsfi(1,nlay,alim    ,'alim   ','alim   ')
+      call wrgradsfi(1,1,f,'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot,'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,alim_star2,'a_2      ','a_2      ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec,'z_sec      ','z_sec      ')
+c      call wrgradsfi(1,1,zmax_sec2,'zz_se      ','zz_se      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      call wrgradsfi(1,1,nivcon,'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon,'zcon      ','zcon      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec,'w_sec      ','w_sec      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+           str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+      SUBROUTINE thermcell_eau(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+ 
+      PARAMETER (DDT0=.01)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c
+
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+c
+c-----------------------------------------------------------------------
+cAM Calcul de T,q,ql a partir de Tl et qT
+c   ---------------------------------------------------
+c
+c Pr Tprec=Tl calcul de qsat 
+c Si qsat>qT T=Tl, q=qT
+c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+c On cherche DDT < DDT0
+c
+c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+c
+c
+       DO ll=1,nlay
+c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 0.00001)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (DT.gt.DDT0)
+c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+c          dqsat_dT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              DT=num/denom
+            enddo
+c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+         EndDO
+       EndDO
+cAM fin
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+c            zo(ig,l)=po(ig,l)
+c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+cAM attention zh est maintenant le profil de T et plus le profil de theta !
+c
+c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))
+     s           -zl(ig,l))
+cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+c            
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-1,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).lt.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                          (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo
+c
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+cAM
+               ztla(ig,l)=zthl(ig,l)
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+cAM
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+c
+cAM on melange Tl et qt du thermique
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)
+     s                    *zthl(ig,l))/f_star(ig,l+1)
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)
+     s                    *po(ig,l))/f_star(ig,l+1)
+c
+c               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+c     s                    *ztv(ig,l))/f_star(ig,l+1)
+c
+cAM on en deduit thetav et ql du thermique
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+               Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 0.00001)
+            endif
+         enddo
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+              do while (DT.gt.DDT0)
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+           endif
+c on ecrit de maniere conservative (sat ou non)
+c          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+     s              -zqla(ig,l))-zqla(ig,l))
+
+        enddo
+        DO ig=1,ngrid
+           if (zw2(ig,l).ge.1.e-10.and.
+     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+c
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))
+     s             *entr_star_tot(ig)
+ctest
+             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+     s             *wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+         first=.true.
+      enddo
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+         else 
+         zmix(ig)=0.
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c     print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zh,zdhadj,zha)
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c     print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',
+     s        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c     print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE thermcell(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                           (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+
+      subroutine dqthermcell(ngrid,nlay,ptimestep,fm,entr,
+     .           masse,q,dq,qa)
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+ctest
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+c               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+c     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+c               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+c               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+c               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+c               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+c               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+c            if (dq(ig,k).lt.0.) then
+c               print*,'dq<0!!!'
+c            endif
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev)
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itère sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+c              gamma0=0.
+c   la première fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*u(ig,k)
+            wvd(ig,k)=fm(ig,k)*v(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*u(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*v(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac
+     .    ,q,dq,qa)
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay),frac(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+      real qe(klon,klev),zf,zf2
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+         qe(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+               zf=0.5*(frac(ig,k)+frac(ig,k+1))
+               zf2=1./(1.-zf)
+               qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2)
+               qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2
+            else
+               qa(ig,k)=q(ig,k)
+               qe(ig,k)=q(ig,k)
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*qe(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),zf,zf2
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real ue(klon,klev),ve(klon,klev)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itère sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+     s         *1.
+c    s         *0.5
+c              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+c   la première fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+c   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+c   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      SUBROUTINE thermcell_sec(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di,tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+c     s                           (zlev(ig,l+1)-zlev(ig,l))
+     s                           *sqrt(zlev(ig,l+1))
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+c      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+c      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+cCR:test pour entrainer moins que la masse
+       do ig=1,ngrid
+          do l=1,lentr(ig)
+             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+     s                       -0.9*masse(ig,l)/ptimestep
+                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+             endif
+          enddo
+       enddo
+cCR: fin test
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+c                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+cRC
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+c      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+               stop'fracd trop petit'
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/float(tho)
+         entr0=entr0+ptimestep*(entr-entr0)/float(tho)
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c      print*,'19 OK convect8'
+      return
+      end
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_out1d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_out1d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_out1d.h	(revision 984)
@@ -0,0 +1,23 @@
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!   recalcul des flux en diagnostique...
+!     print*,'PAS DE TEMPS ',ptimestep
+!       call dt2F(pplev,pplay,pt,pdtadj,wh)
+!      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_out3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_out3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_out3d.h	(revision 984)
@@ -0,0 +1,72 @@
+!       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,w_est,'w_est      ','w_est      ')
+!on sort les moments
+         call wrgradsfi(1,nlay,thetath2,'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2,'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3,'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2,'q2       ','q2       ')
+!
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa,'zoa        ','zoa        ')
+
+!nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',  &
+     &        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz,'deltaz      ','deltaz      ')
+!nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  ,'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    ,'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    ,'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    ,'alim_star   ','alim_star   ')
+      call wrgradsfi(1,nlay,alim    ,'alim   ','alim   ')
+      call wrgradsfi(1,1,f,'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot,'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,alim_star2,'a_2      ','a_2      ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec,'z_sec      ','z_sec      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      call wrgradsfi(1,1,nivcon,'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon,'zcon      ','zcon      ')
+      call wrgradsfi(1,1,zcon2,'zcon2      ','zcon2      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec,'w_sec      ','w_sec      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+      print*,'Fin des wrgradsfi'
Index: LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_plume.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_plume.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/thermcell_plume.F90	(revision 984)
@@ -0,0 +1,386 @@
+      SUBROUTINE thermcell_plume(ngrid,klev,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,  &
+     &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,zqsatth,lmix,linter,lev_out)
+
+!--------------------------------------------------------------------------
+!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
+!--------------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+      INTEGER ngrid,klev
+      REAL ztv(ngrid,klev)
+      REAL zthl(ngrid,klev)
+      REAL po(ngrid,klev)
+      REAL zl(ngrid,klev)
+      REAL rhobarz(ngrid,klev)
+      REAL zlev(ngrid,klev+1)
+      REAL pplev(ngrid,klev+1)
+      REAL pphi(ngrid,klev)
+      REAL zpspsk(ngrid,klev)
+      REAL alim_star(ngrid,klev)
+      REAL zmax_sec(ngrid)
+      REAL f0(ngrid)
+      REAL l_mix
+      REAL r_aspect
+      INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+      REAL ztva(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zqla(ngrid,klev)
+      REAL zqta(ngrid,klev)
+      REAL zha(ngrid,klev)
+
+      REAL detr_star(ngrid,klev)
+      REAL entr_star(ngrid,klev)
+      REAL detr(ngrid,klev)
+      REAL entr(ngrid,klev)
+
+      REAL zw2(ngrid,klev+1)
+      REAL w_est(ngrid,klev+1)
+      REAL f_star(ngrid,klev+1)
+      REAL wa_moy(ngrid,klev+1)
+
+      REAL ztva_est(ngrid,klev)
+      REAL zqla_est(ngrid,klev)
+      REAL zqsatth(ngrid,klev)
+
+      REAL linter(ngrid)
+      INTEGER lmix(ngrid)
+      REAL    wmaxa(ngrid)
+
+      INTEGER ig,l,k
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef,qsatbef
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      logical Zsat
+
+      Zsat=.false.
+! Initialisation
+      RLvCp = RLVTT/RCPD
+     
+      do l=1,klev
+         do ig=1,ngrid
+            zqla_est(ig,l)=0.
+            ztva_est(ig,l)=ztva(ig,l)
+            zqsatth(ig,l)=0.
+         enddo
+      enddo
+
+!AM:initialisations du thermique
+      do k=1,klev
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+      if (lev_out.ge.1) print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            w_est(ig,k)=0.
+            f_star(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+      if (lev_out.ge.1) print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+!-----------------------------------------------------------------------------------
+!boucle de calcul de la vitesse verticale dans le thermique
+!-----------------------------------------------------------------------------------
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)  &
+     &         .and.alim_star(ig,l).gt.1.e-10  &
+     &         .and.zw2(ig,l).lt.1e-10) then
+               ztla(ig,l)=zthl(ig,l) 
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+               f_star(ig,l+1)=alim_star(ig,l)
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+!
+            else if ((zw2(ig,l).ge.1e-10).and.  &
+     &         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+!estimation du detrainement a partir de la geometrie du pas precedent
+!tests sur la definition du detr
+!calcul de detr_star et entr_star
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH le test miraculeux de Catherine ? Le bout du tunel ?
+!               w_est(ig,3)=zw2(ig,2)*  &
+!    &                   ((f_star(ig,2))**2)  &
+!    &                   /(f_star(ig,2)+alim_star(ig,2))**2+  &
+!    &                   2.*RG*(ztva(ig,1)-ztv(ig,2))/ztv(ig,2)  &
+!    &                   *(zlev(ig,3)-zlev(ig,2))
+!     if (l.gt.2) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      if (l.gt.2) then
+          w_est(ig,3)=zw2(ig,2)* &
+     &      ((f_star(ig,2))**2) &
+     &      /(f_star(ig,2)+alim_star(ig,2))**2+ &
+     &      2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) &
+     &      *(zlev(ig,3)-zlev(ig,2))
+
+
+!---------------------------------------------------------------------------
+!calcul de l entrainement et du detrainement lateral
+!---------------------------------------------------------------------------
+!
+!test:estimation de ztva_new_est sans entrainement
+               Tbef=ztla(ig,l-1)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               Zsat = (max(0.,zqta(ig,l-1)-qsatbef) .gt. 1.e-10)
+               if (Zsat) then
+               qlbef=max(0.,zqta(ig,l-1)-qsatbef)
+               DT = 0.5*RLvCp*qlbef
+               do while (abs(DT).gt.DDT0)
+                 Tbef=Tbef+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig,l-1)-qsatbef
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef+ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+               enddo
+                 zqla_est(ig,l) = max(0.,zqta(ig,l-1)-qsatbef) 
+               endif
+        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
+     &      -zqla_est(ig,l))-zqla_est(ig,l))
+
+             w_est(ig,l+1)=zw2(ig,l)*  &
+     &                   ((f_star(ig,l))**2)  &
+     &                   /(f_star(ig,l)+alim_star(ig,l))**2+  &
+     &                   2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+!
+!calcul du detrainement
+          if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
+     &       (zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
+     &       (zqla(ig,l-1).lt.1.e-10)) then 
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
+     &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
+     &       /(r_aspect*zmax_sec(ig)))
+       if (lev_out.ge.20) print*,'coucou calcul detr 1'
+          else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
+     &            (zqla(ig,l-1).lt.1.e-10)) then
+             detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
+     &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
+     &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
+     &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
+     &       *((zmax_sec(ig)-zlev(ig,l))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
+        if (lev_out.ge.20) print*,'coucou calcul detr 2'
+          else
+             detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
+     &                      *(zlev(ig,l+1)-zlev(ig,l))
+        if (lev_out.ge.20) print*,'coucou calcul detr 3'
+             
+          endif
+          detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+!
+!calcul de entr_star
+!
+! Deplacement du calcul de entr_star pour eviter d'avoir aussi
+! entr_star > fstar.
+! Redeplacer suite a la transformation du cas detr>f
+! FH
+        if(l.gt.lalim(ig)) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+        else
+
+! FH :
+! Cette ligne doit permettre de garantir qu'on a toujours un flux = 1
+! en haut de la couche d'alimentation.
+! A remettre en questoin a la premiere occasion mais ca peut aider a 
+! ecrire un code robuste.
+! Que ce soit avec ca ou avec l'ancienne facon de faire (e* = 0 mais
+! d* non nul) on a une discontinuité de e* ou d* en haut de la couche
+! d'alimentation, ce qui n'est pas forcement heureux.
+         entr_star(ig,l)=max(detr_star(ig,l)-alim_star(ig,l),0.)
+         detr_star(ig,l)=entr_star(ig,l)
+        endif
+
+!
+        if (detr_star(ig,l).gt.f_star(ig,l)) then
+
+!  Ce test est là entre autres parce qu'on passe par des valeurs
+!  delirantes de detr_star.
+!  ca vaut sans doute le coup de verifier pourquoi.
+
+           detr_star(ig,l)=f_star(ig,l)
+           if (l.gt.lalim(ig)+1) then
+               entr_star(ig,l)=0.
+               alim_star(ig,l)=0.
+! FH ajout pour forcer a stoper le thermique juste sous le sommet
+! de la couche (voir calcul de finter)
+               zw2(ig,l+1)=-1.e-10
+               linter(ig)=l+1
+            else
+               entr_star(ig,l)=detr_star(ig,l)
+            endif
+        endif
+
+      else
+         detr_star(ig,l)=0.
+         entr_star(ig,l)=0.
+      endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH inutile si on conserve comme on l'a fait plus haut entr=detr
+! dans la couche d'alimentation
+!pas d entrainement dans la couche alim
+!      if ((l.le.lalim(ig))) then
+!           entr_star(ig,l)=0.
+!      endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!prise en compte du detrainement et de l entrainement dans le calcul du flux
+      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
+     &              -detr_star(ig,l)
+
+!test sur le signe de f_star
+       if (f_star(ig,l+1).gt.1.e-10) then 
+!----------------------------------------------------------------------------
+!calcul de la vitesse verticale en melangeant Tl et qt du thermique
+!---------------------------------------------------------------------------
+!
+       Zsat=.false.
+       ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+!
+       zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+!  
+               Tbef=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)               
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               Zsat = (max(0.,zqta(ig,l)-qsatbef) .gt. 1.e-10)
+               if (Zsat) then
+               qlbef=max(0.,zqta(ig,l)-qsatbef)
+               DT = 0.5*RLvCp*qlbef
+               do while (abs(DT).gt.DDT0)
+                 Tbef=Tbef+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig,l)-qsatbef
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+                 zqla(ig,l) = max(0.,qlbef) 
+              endif
+!    
+! on ecrit de maniere conservative (sat ou non)
+!          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!on rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)  &
+     &              -zqla(ig,l))-zqla(ig,l))
+
+!on ecrit zqsat 
+           zqsatth(ig,l)=qsatbef  
+!calcul de vitesse
+           zw2(ig,l+1)=zw2(ig,l)*  &
+     &                 ((f_star(ig,l))**2)  &
+     &                 /(f_star(ig,l+1)+detr_star(ig,l))**2+             &
+     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                 *(zlev(ig,l+1)-zlev(ig,l))
+               
+            endif
+        endif
+!
+!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max 
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+                print*,'On tombe sur le cas particulier de thermcell_plume'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+            endif
+
+
+        if (zw2(ig,l+1).lt.0.) then 
+           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+           zw2(ig,l+1)=0.
+        endif
+
+           wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) 
+
+        if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+            lmix(ig)=l+1
+            wmaxa(ig)=wa_moy(ig,l+1)
+        endif
+        enddo
+      enddo
+
+
+      return 
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/tilft43.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/tilft43.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/tilft43.F	(revision 984)
@@ -0,0 +1,95 @@
+!
+! $Header$
+!
+        SUBROUTINE TLIFT43(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
+        REAL GZ(ND),TPK(ND),CLW(ND),P(ND)
+        REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c -- sb:
+c!      CPD=1005.7
+c!      CPV=1870.0
+c!      CL=4190.0
+c!      RV=461.5
+c!      RD=287.04
+c!      LV0=2.501E6
+c!      G=9.8
+c!      ROWL=1000.0
+c ajouts:
+#include "YOMCST.h"
+        CPD = RCPD
+        CPV = RCPV
+        CL = RCW
+        LV0 = RLVTT
+        G = RG
+        ROWL= RATM/100.
+        GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+C sb --
+C
+        CPVMCL=CL-CPV
+        EPS=RD/RV
+        EPSI=1./EPS
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*(LV0-CPVMCL*(
+     1   T(NK)-273.15))+GZ(NK)
+        CPP=CPD*(1.-Q(NK))+Q(NK)*CPV
+        CPINV=1./CPP
+C
+        IF(KK.EQ.1)THEN
+C
+C   ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
+C
+        DO 50 I=1,ICB-1
+         CLW(I)=0.0
+   50   CONTINUE
+        DO 100 I=NK,ICB-1
+         TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV
+         TVP(I)=TPK(I)*(1.+Q(NK)*EPSI)
+  100   CONTINUE
+        END IF
+C
+C    ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
+C
+        NST=ICB
+        NSB=ICB
+        IF(KK.EQ.2)THEN  
+         NST=NL
+         NSB=ICB+1
+        END IF
+        DO 300 I=NSB,NST
+         TG=T(I)
+         QG=QS(I)
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         DO 200 J=1,2
+          S=CPD+ALV*ALV*QG/(RV*T(I)*T(I))
+          S=1./S
+          AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I)
+          TG=TG+S*(AH0-AHG)
+          TG=MAX(TG,35.0)
+          TC=TG-273.15
+          DENOM=243.5+TC
+          IF(TC.GE.0.0)THEN  
+           ES=6.112*EXP(17.67*TC/DENOM)
+          ELSE  
+           ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+          END IF  
+          QG=EPS*ES/(P(I)-ES*(1.-EPS))
+  200    CONTINUE
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD
+         CLW(I)=Q(NK)-QG
+         CLW(I)=MAX(0.0,CLW(I))
+         RG=QG/(1.-Q(NK))
+         TVP(I)=TPK(I)*(1.+RG*EPSI)
+  300   CONTINUE
+
+c -- sb:
+        RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+c sb --
+
+        RETURN
+        END
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/tlift.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/tlift.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/tlift.F	(revision 984)
@@ -0,0 +1,245 @@
+!
+! $Header$
+!
+        SUBROUTINE TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,
+     .                  TVP,TPK,CLW,ND,NL,
+     .                  DTVPDT1,DTVPDQ1)
+C
+C     Argument NK ajoute (jyg) = Niveau de depart de la
+C     convection
+C
+        PARAMETER (NA=60)
+        REAL GZ(ND),TPK(ND),CLW(ND)
+        REAL T(ND),RR(ND),RS(ND),TVP(ND),P(ND)
+        REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                   temperature wrt T1 and Q1
+C
+        REAL CLW_NEW(NA),QI(NA)
+        REAL DTPDT1(NA),DTPDQ1(NA)      ! Derivatives of parcel temperature
+C                                   wrt T1 and Q1
+ 
+C
+        LOGICAL ICE_CONV
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c sb        CPD=1005.7
+c sb      CPV=1870.0
+c sb        CL=4190.0
+c sb        CPVMCL=2320.0
+c sb        RV=461.5
+c sb        RD=287.04
+c sb        EPS=RD/RV
+c sb        ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CI=2090.0
+c sb      CPVMCL=CL-CPV
+c sb      CLMCI=CL-CI
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+c sb      ALF0=3.34E+05
+ 
+cccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+       GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CI = RCS
+       CPVMCL = CL-CPV
+       CLMCI = CL-CI
+       EPS = RD/RV
+       ALV0 = RLVTT
+       ALF0 = RLMLT ! (ALF0 = RLSTT-RLVTT)
+c 
+cccccccccccccccccccccc
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        ICB1=MAX(ICB,2)
+        ICB1=MIN(ICB,NL)
+C
+Cjyg1
+CC      CPP=CPD*(1.-RR(1))+RR(1)*CPV
+      CPP=CPD*(1.-RR(NK))+RR(NK)*CPV
+Cjyg2
+      CPINV=1./CPP
+Cjyg1
+C         ICB may be below condensation level
+CCC        DO 100 I=1,ICB1-1
+CCC         TPK(I)=T(1)-GZ(I)*CPINV
+CCC         TVP(I)=TPK(I)*(1.+RR(1)/EPS)
+        DO 50 I=1,ICB1
+         CLW(I)=0.0
+50      CONTINUE
+C
+        DO 100 I=NK,ICB1
+         TPK(I)=T(NK)-(GZ(I) - GZ(NK))*CPINV
+Cjyg1
+CCC         TVP(I)=TPK(I)*(1.+RR(NK)/EPS)
+         TVP(I)=TPK(I)*(1.+RR(NK)/EPS-RR(NK))
+Cjyg2
+         DTVPDT1(I) = 1.+RR(NK)/EPS-RR(NK)
+         DTVPDQ1(I) = TPK(I)*(1./EPS-1.)
+C
+Cjyg2
+ 
+  100   CONTINUE
+ 
+C
+C    ***  FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO    ***
+C
+Cjyg1
+CC        AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1)
+CC     $     +RR(1)*(ALV0-CPVMCL*(T(1)-273.15))
+        AH0=(CPD*(1.-RR(NK))+CL*RR(NK))*T(NK)
+     $     +RR(NK)*(ALV0-CPVMCL*(T(NK)-273.15)) + GZ(NK)
+Cjyg2
+C
+Cjyg1
+        IMIN = ICB1
+C         If ICB is below LCL, start loop at ICB+1
+        IF (PLCL .LT. P(ICB1)) IMIN = MIN(IMIN+1,NL)
+C
+CCC        DO 300 I=ICB1,NL
+        DO 300 I=IMIN,NL
+Cjyg2
+         ALV=ALV0-CPVMCL*(T(I)-273.15)
+         ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        RG=RS(I)
+        TG=T(I)
+C       S=CPD+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg1
+CC        S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I))
+        S=CPD*(1.-RR(NK))+CL*RR(NK)+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg2
+        S=1./S
+ 
+        DO 200 J=1,2
+Cjyg1
+CC         AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I)
+         AHG=CPD*TG+(CL-CPD)*RR(NK)*TG+ALV*RG+GZ(I)
+Cjyg2
+        TG=TG+S*(AH0-AHG)
+        TC=TG-273.15
+        DENOM=243.5+TC
+        DENOM=MAX(DENOM,1.0)
+C
+C       FORMULE DE BOLTON POUR PSAT
+C
+        ES=6.112*EXP(17.67*TC/DENOM)
+        RG=EPS*ES/(P(I)-ES*(1.-EPS))
+ 
+ 
+  200   CONTINUE
+ 
+Cjyg1
+CC        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1))
+        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(NK))
+Cjyg2
+C       TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD
+ 
+Cjyg1
+CC        CLW(I)=RR(1)-RG
+        CLW(I)=RR(NK)-RG
+Cjyg2
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+RG/EPS)
+        TVP(I)=TPK(I)*(1.+RG/EPS-RR(NK))
+Cjyg2
+C
+Cjyg1       Derivatives
+C
+        DTPDT1(I) = CPD*S
+        DTPDQ1(I) = ALV*S
+C
+         DTVPDT1(I) = DTPDT1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) )
+        DTVPDQ1(I) = DTPDQ1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) ) - TPK(I)
+C
+Cjyg2
+ 
+  300   CONTINUE
+C
+      ICE_CONV = .FALSE.
+
+      IF (ICE_CONV) THEN
+C
+CJAM
+C       RAJOUT DE LA PROCEDURE ICEFRAC
+C
+c sb        CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL)
+ 
+        DO 400 I=ICB1,NL
+        IF (T(I).LT.263.15) THEN
+        TG=TPK(I)
+        TC=TPK(I)-273.15
+        DENOM=243.5+TC
+        ES=6.112*EXP(17.67*TC/DENOM)
+        ALV=ALV0-CPVMCL*(T(I)-273.15)
+        ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        DO J=1,4
+        ESI=EXP(23.33086-(6111.72784/TPK(I))+0.15215*LOG(TPK(I)))
+        QSAT_NEW=EPS*ESI/(P(I)-ESI*(1.-EPS))
+CCC        SNEW= CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+        SNEW= CPD*(1.-RR(NK))+CL*RR(NK)
+     .        +ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+C
+        SNEW=1./SNEW
+        TPK(I)=TG+(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+c@$$        PRINT*,'################################'
+c@$$        PRINT*,TPK(I)
+c@$$        PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+        ENDDO
+CCC        CLW(I)=RR(1)-QSAT_NEW
+        CLW(I)=RR(NK)-QSAT_NEW
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS)
+        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS-RR(NK))
+Cjyg2
+        ELSE
+        CONTINUE
+        ENDIF
+ 
+  400   CONTINUE
+C
+      ENDIF
+C
+ 
+******************************************************
+** BK :  RAJOUT DE LA TEMPERATURE DES ASCENDANCES
+**   NON DILUES AU  NIVEAU KLEV = ND
+**   POSONS LE ENVIRON EGAL A CELUI DE KLEV-1
+********************************************************
+ 
+      TPK(NL+1)=TPK(NL)
+ 
+*******************************************************
+
+      RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+ 
+ 
+        RETURN
+        END
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
Index: LMDZ4/tags/LF_20080728/libf/phytherm/transp.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/transp.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/transp.F	(revision 984)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE transp (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c 
+       USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), e
+c     ------------------------------------------------------------------
+      DO i = 1, klon
+         utran_e(i) = 0.0
+         utran_q(i) = 0.0
+         vtran_e(i) = 0.0
+         vtran_q(i) = 0.0
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i)=utran_q(i)+ u(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/transp_lay.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/transp_lay.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/transp_lay.F	(revision 984)
@@ -0,0 +1,53 @@
+!
+! $Header$
+!
+      SUBROUTINE transp_lay (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon,klev), utran_q(klon,klev)
+      REAL vtran_e(klon,klev), vtran_q(klon,klev)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), esh
+c     ------------------------------------------------------------------
+      DO l = 1, klev
+      DO i = 1, klon
+         utran_e(i,l) = 0.0
+         utran_q(i,l) = 0.0
+         vtran_e(i,l) = 0.0
+         vtran_q(i,l) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         esh = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i,l)=utran_e(i,l)+ u(i,l)*esh*
+     .                (paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i,l)=utran_q(i,l)+ u(i,l)*q(i,l)
+     .                *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i,l)=vtran_e(i,l)+ v(i,l)*esh*
+     .                (paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i,l)=vtran_q(i,l)+ v(i,l)*q(i,l)
+     .                *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/undefSTD.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/undefSTD.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/undefSTD.F	(revision 984)
@@ -0,0 +1,87 @@
+!
+! $Header$
+!
+      SUBROUTINE undefSTD(nlevSTD,itap,tlevSTD,
+     $           dtime,ecrit_hf,
+     $           oknondef,tnondef,tsumSTD)
+      USE dimphy
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) 
+c          ou la variable tlevSTD est bien definie (.NE.1.E+20), 
+c et 
+c        * de la somme de tlevSTD => tsumSTD
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c        ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c        ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c
+c NB: mettre "inst(X)" dans le write_histXXX.h !
+c====================================================================
+c
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c variables Input
+      INTEGER nlevSTD, klevSTD, itap
+      PARAMETER(klevSTD=17)
+      REAL dtime, ecrit_hf
+c
+c variables locales
+      INTEGER i, k, nout
+      PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+c
+c variables Output
+      REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
+      LOGICAL oknondef(klon,klevSTD,nout)
+      REAL tnondef(klon,klevSTD,nout)
+c
+c calcul variables tous les pas de temps de la physique 
+c
+      DO k=1, nlevSTD
+       DO i=1, klon
+        IF(tlevSTD(i,k).EQ.1E+20) THEN
+         IF(oknondef(i,k,1)) THEN          
+          tnondef(i,k,1)=tnondef(i,k,1)+1.
+         ENDIF !oknondef(i,k)
+c
+         IF(oknondef(i,k,2)) THEN          
+          tnondef(i,k,2)=tnondef(i,k,2)+1.
+         ENDIF !oknondef(i,k)
+c
+        ELSE IF(tlevSTD(i,k).NE.1E+20) THEN
+         tsumSTD(i,k,1)=tsumSTD(i,k,1)+tlevSTD(i,k)
+         tsumSTD(i,k,2)=tsumSTD(i,k,2)+tlevSTD(i,k)
+        ENDIF 
+       ENDDO !i
+      ENDDO !k
+c
+c calcul variables toutes les 6h
+c
+      IF(MOD(itap,NINT(ecrit_hf/dtime)).EQ.0) THEN
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tlevSTD(i,k).EQ.1E+20) THEN
+          IF(oknondef(i,k,3)) THEN          
+           tnondef(i,k,3)=tnondef(i,k,3)+1.
+          ENDIF !oknondef(i,k)
+c
+         ELSE IF(tlevSTD(i,k).NE.1E+20) THEN
+         tsumSTD(i,k,3)=tsumSTD(i,k,3)+tlevSTD(i,k)
+         ENDIF 
+        ENDDO !i
+       ENDDO !k
+
+      ENDIF !MOD(itap,NINT(ecrit_hf/dtime)).EQ.0
+c
+      RETURN
+      END  
Index: LMDZ4/tags/LF_20080728/libf/phytherm/ustarhb.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/ustarhb.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/ustarhb.F	(revision 984)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE ustarhb(knon,u,v,cd_m, ustar)
+      use dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+      REAL ustar(klon)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      DO i = 1, knon
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+c       print*,'Ust ',zxu,zxmod,taux,ustar(i)
+      ENDDO
+c
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/vdif_kcay.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/vdif_kcay.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/vdif_kcay.F	(revision 984)
@@ -0,0 +1,743 @@
+!
+! $Header$
+!
+      SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c 
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),q2s(klon,klev+1)
+      REAL q2diag(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon)
+
+      integer l_mix,iii
+c.......................................................................
+c
+c nlay : nombre de couches        
+c nlev : nombre de niveaux
+c ngrid : nombre de points de grille       
+c unsdz : 1 sur l'epaisseur de couche
+c unsdzdec : 1 sur la distance entre le centre de la couche et le
+c            centre de la couche inferieure
+c q : echelle de vitesse au bas de chaque couche
+c     (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      INTEGER nlay,nlev,ngrid
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+      REAL q(klon,klev+1)
+
+c.......................................................................
+c
+c kmpre : km au debut du pas de temps
+c qcstat : q : solution stationnaire du probleme couple
+c          (valeur a la fin du pas de temps)
+c q2cstat : q2 : solution stationnaire du probleme couple
+c           (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL kmpre(klon,klev+1)
+      REAL qcstat
+      REAL q2cstat
+      real sss,sssq
+c.......................................................................
+c
+c long : longueur de melange calculee selon Blackadar
+c
+c.......................................................................
+      REAL long(klon,klev+1)
+c.......................................................................
+c
+c kmq3 : terme en q^3 dans le developpement de km
+c        (valeur au debut du pas de temps)
+c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c knq3 : terme en q^3 dans le developpement de kn
+c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+c          (valeur a la fin du pas de temps)
+c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c m : valeur a la fin du pas de temps
+c mpre : valeur au debut du pas de temps
+c m2 : valeur a la fin du pas de temps
+c n2 : valeur a la fin du pas de temps
+c 
+c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(klon,klev+1)
+      REAL mpre(klon,klev+1)
+      REAL m2(klon,klev+1)
+      REAL n2(klon,klev+1)
+c.......................................................................
+c
+c gn : intermediaire pour les coefficients de stabilite
+c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+c gnmax : borne superieure de gn (0.0233)
+c gninf : vrai si gn est en dessous de sa borne inferieure
+c gnsup : vrai si gn est en dessus de sa borne superieure
+c gm : drole d'objet bien utile
+c ri : nombre de Richardson
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c sm : coefficient de stabilite pour m
+c smq2 : premier terme du developement limite de sm en q2
+c
+c.......................................................................
+      REAL gn
+      REAL gnmin
+      REAL gnmax
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+c      REAL ri(klon,klev+1)
+      REAL sn(klon,klev+1)
+      REAL snq2(klon,klev+1)
+      REAL sm(klon,klev+1)
+      REAL smq2(klon,klev+1)
+c.......................................................................
+c
+c kappa : consatnte de Von Karman (0.4)
+c long00 : longueur de reference pour le calcul de long (160)
+c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+c cn1,cn2 : constantes pour sn
+c cm1,cm2,cm3,cm4 : constantes pour sm
+c
+c.......................................................................
+      REAL kappa
+      REAL long00
+      REAL a1,a2,b1,b2,c1
+      REAL cn1,cn2
+      REAL cm1,cm2,cm3,cm4
+c.......................................................................
+c
+c termq : termes en $q$ dans l'equation de q2
+c termq3 : termes en $q^3$ dans l'equation de q2
+c termqm2 : termes en $q*m^2$ dans l'equation de q2
+c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+c
+c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+c.......................................................................
+c
+c q2min : borne inferieure de q2
+c q2max : borne superieure de q2
+c
+c.......................................................................
+      REAL q2min
+      REAL q2max
+c.......................................................................
+c knmin : borne inferieure de kn
+c kmmin : borne inferieure de km
+c.......................................................................
+      REAL knmin
+      REAL kmmin
+c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+c.......................................................................
+      PARAMETER (kappa=0.4E+0)
+      PARAMETER (long00=160.E+0)
+c     PARAMETER (gnmin=-10.E+0)
+      PARAMETER (gnmin=-0.28)
+      PARAMETER (gnmax=0.0233E+0)
+      PARAMETER (a1=0.92E+0)
+      PARAMETER (a2=0.74E+0)
+      PARAMETER (b1=16.6E+0)
+      PARAMETER (b2=10.1E+0)
+      PARAMETER (c1=0.08E+0)
+      PARAMETER (knmin=1.E-5)
+      PARAMETER (kmmin=1.E-5)
+      PARAMETER (q2min=1.e-5)
+      PARAMETER (q2max=1.E+2)
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+c
+      PARAMETER (
+     &  cn1=a2*(1.E+0 -6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cn2=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1)
+     &          -3.E+0 *c1*(b2+6.E+0 *a1)))
+     &          )
+      PARAMETER (
+     &  cm3=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm4=-9.E+0 *a1*a2
+     &          )
+
+      logical first
+      save first
+      data first/.true./
+c$OMP THREADPRIVATE(first)
+c.......................................................................
+c  traitment des valeur de q2 en entree
+c.......................................................................
+c
+c   Initialisation de q2
+      nlay=klev
+      nlev=klev+1
+       
+      call yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar
+     s   ,l_mix)
+      if (first.and.1.eq.1) then
+      first=.false.
+      q2=q2diag
+      endif
+
+      DO ilev=1,nlev
+                                                      DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+                                                      ENDDO
+      ENDDO
+c
+                                                      DO igrid=1,ngrid 
+      tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+      q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+      q2(igrid,1)=amax1(q2(igrid,1),q2min)
+      q(igrid,1)=sqrt(q2(igrid,1))
+                                                      ENDDO
+c
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO igrid=1,ngrid 
+            zlev(igrid,nlev)=zlay(igrid,nlay)
+     &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+                                                      ENDDO            
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO ilay=1,nlay
+                                                      DO igrid=1,ngrid 
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+                                                      ENDDO
+      DO ilay=2,nlay
+                                                      DO igrid=1,ngrid 
+        unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+                                                      ENDDO
+c
+c.......................................................................
+c  le cisaillement et le gradient de temperature
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,1)=(unsdzdec(igrid,1)
+     &                   *u(igrid,1))**2
+     &                 +(unsdzdec(igrid,1)
+     &                   *v(igrid,1))**2
+      m(igrid,1)=sqrt(m2(igrid,1))
+      mpre(igrid,1)=m(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)
+     &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))
+     &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+c       n2(igrid,ilev)=0.
+c
+c --->
+c       on ne sais traiter que les cas stratifies. et l'ajustement
+c       convectif est cense faire en sorte que seul des configurations
+c       stratifiees soient rencontrees en entree de cette routine.
+c       mais, bon ... on sait jamais (meme on sait que n2 prends
+c       quelques valeurs negatives ... parfois) alors : 
+c<---
+c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)
+     &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2
+     &                   +(unsdzdec(igrid,ilev)
+     &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,nlev)=m2(igrid,nlev-1)
+      m(igrid,nlev)=m(igrid,nlev-1)
+      mpre(igrid,nlev)=m(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  calcul des fonctions de stabilite
+c.......................................................................
+c
+      if (l_mix.eq.4) then
+                                                      DO igrid=1,ngrid 
+         sqz(igrid)=1.e-10
+         sq(igrid)=1.e-10
+                                                      ENDDO
+         do ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+           zq=sqrt(q2(igrid,ilev))
+           sqz(igrid)
+     .     =sqz(igrid)+zq*zlev(igrid,ilev)
+     .     *(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+           sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+                                                      ENDDO
+         enddo
+                                                      DO igrid=1,ngrid 
+         long0(igrid)=0.2*sqz(igrid)/sq(igrid)
+                                                      ENDDO
+      else if (l_mix.eq.3) then
+         long0(igrid)=long00
+      endif
+
+c (abd 5 2)      print*,'LONG0=',long0
+
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        if (l_mix.ge.10) then
+            long(igrid,ilev)=l_mix
+        else
+           long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid))
+        endif
+        long(igrid,ilev)=max(min(long(igrid,ilev)
+     s    ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10)))
+     s    ,5.)
+
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * m2(igrid,ilev)
+c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)
+     &     *(1.E+0 +cm4*gn) )
+c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=
+     &     -gn
+     &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=
+     &     -gn
+     &     *( cm2*(1.E+0 +cm3*gn)
+     &           *(1.E+0 +cm4*gn)
+     &       -( cm3*(1.E+0 +cm4*gn)
+     &         +cm4*(1.E+0 +cm3*gn) )
+     &       *(cm1+cm2*gn)            )
+     &     /( (1.E+0 +cm3*gn)
+     &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+c
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c --->
+c       la decomposition de Taylor en q2 n'a de sens que
+c       dans les cas stratifies ou sn et sm sont quasi
+c       proportionnels a q2. ailleurs on laisse le meme
+c       algorithme car l'ajustement convectif fait le travail.
+c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+c       signe : dans ces cas, on ne fait pas la decomposition.
+c<---
+c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)
+     &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)
+     &      smq2(igrid,ilev)=0.E+0
+c
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde       print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+c.......................................................................
+c  calcul de km et kn au debut du pas de temps
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      kmpre(igrid,1)=km(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+      kmpre(igrid,nlev)=km(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  boucle sur les niveaux 2 a nlev-1
+c.......................................................................
+c
+c---->
+      DO 10001 ilev=2,nlev-1
+c---->
+      DO 10002 igrid=1,ngrid 
+c
+c.......................................................................
+c
+c  calcul des termes sources et puits de l'equation de q2
+c  ------------------------------------------------------
+c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)
+     &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)
+     &                                    /sm(igrid,ilev)
+c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2
+     &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+     &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2
+     &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+c 
+        termq=termq
+     &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)
+     &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3
+     &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+c
+        termq3=termq3
+     &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+c
+c.......................................................................
+c
+c  resolution stationnaire couplee avec le gradient de vitesse local
+c  -----------------------------------------------------------------
+c
+c  -----{on cherche le cisaillement qui annule l'equation de q^2
+c        supposee en q3}
+c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)
+     &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+
+c  abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)
+     &              *cd(igrid)
+     &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)
+     &                -mcstat/unsdzdec(igrid,ilev)
+     &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)
+     &                          *mpre(igrid,ilev-1) )
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat
+     &      /( sm(igrid,ilev)/q2(igrid,ilev) )
+     &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+c
+c.......................................................................
+c
+c  choix de la solution finale
+c  ---------------------------
+c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+c abd       if(ilev.le.57.and.ilev.ge.37) then
+c           print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
+c     s     'N2=',n2(igrid,ilev)
+c abd       endif
+          m2(igrid,ilev)=m2cstat
+c
+c --->
+c       pour des raisons simples q2 est minore 
+c<---
+c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+c
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sm(igrid,ilev)
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c
+c.......................................................................
+c
+10002 CONTINUE
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+c     kn(igrid,1)=cd(igrid)
+c     km(igrid,1)=cd(igrid)
+      q2(igrid,nlev)=q2(igrid,nlev-1)
+      q(igrid,nlev)=q(igrid,nlev-1)
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+                                                      ENDDO
+c
+c  CALCUL DE LA DIFFUSION VERTICALE DE Q2
+      if (1.eq.1) then
+
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+c        print*,'Q2moy avant',sssq/sss
+c       print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
+c       print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
+c   ! C'est quoi ca qu'etait dans l'original???
+c       do igrid=1,ngrid
+c          q2(igrid,1)=10.
+c       enddo
+c        q2s=q2
+c       do iii=1,10
+c       call vdif_q2(dt,g,rconst,plev,temp,km,q2)
+c       do ilev=1,klev+1
+c          write(iii+49,*) q2(1,ilev),zlev(1,ilev)
+c       enddo
+c       enddo
+c       stop
+c       do ilev=1,klev
+c          print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
+c       enddo
+c        q2s=q2-q2s
+c       do ilev=1,klev
+c          print*,q2s(1,ilev),zlev(1,ilev)
+c       enddo
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+        print*,'Q2moy apres',sssq/sss
+c
+c
+        do ilev=1,nlev
+           do igrid=1,ngrid
+              q2(igrid,ilev)=max(q2(igrid,ilev),q2min)
+              q(igrid,ilev)=sqrt(q2(igrid,ilev))
+
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde      print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+c
+           enddo
+        enddo
+c       print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
+
+      endif
+
+      RETURN
+      END
Index: LMDZ4/tags/LF_20080728/libf/phytherm/wrgradsfi.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/wrgradsfi.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/wrgradsfi.F	(revision 984)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      implicit none
+
+c   Declarations
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+
+c   arguments
+      integer if,nl
+      real fieldfi_p(klon,nl)
+      real fieldfi(klon_glo,nl)
+      real fielddyn((iim+1)*(jjm+1),llm)
+      character*10 name
+      character*10 titlevar
+
+c   local
+
+      integer lm,l,lnblnk
+
+
+
+c     print*,'Transformation pour ',name
+      call Gather(fieldfi_p,fieldfi)
+
+c$OMP MASTER      
+      if (is_mpi_root) then
+        call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn)
+        
+c     print*,'Transformation OK '
+        call wrgrads(if,nl,fielddyn,name,titlevar)
+c     print*,'Ecriture ok'
+      endif
+c$OMP END MASTER
+      
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_bilKP_ave.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_bilKP_ave.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_bilKP_ave.h	(revision 984)
@@ -0,0 +1,155 @@
+c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+      itau_w = itau_phy + itap
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ue",itau_w,ue_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ve",itau_w,ve_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"uq",itau_w,uq_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vq",itau_w,vq_lay)
+c
+c Champs 3D:
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"play",itau_w,paprs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"oliq",itau_w,cldliq)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqdyn",itau_w,d_q_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtcon",itau_w,d_t_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"ducon",itau_w,d_u_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvcon",itau_w,d_v_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqcon",itau_w,d_q_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlsc",itau_w,d_t_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqlsc",itau_w,d_q_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqvdf",itau_w,d_q_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtajs",itau_w,d_t_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqajs",itau_w,d_q_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dteva",itau_w,d_t_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqeva",itau_w,d_q_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtswr",itau_w,heat)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtsw0",itau_w,heat0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlwr",itau_w,cool)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtlw0",itau_w,cool0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duvdf",itau_w,d_u_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvvdf",itau_w,d_v_vdf)
+c
+      IF (ok_orodr) THEN
+      IF (ok_orolf) THEN
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k)
+        d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k)
+      ENDDO
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duoli",d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvoli",itau_w,d_v_oli)
+c
+      ENDIF
+      ENDIF
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"duphy",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dvphy",itau_w,d_v)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), 
+cymf     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqphy",itau_w,d_qx(:,:,1))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPave,"dqlphy",itau_w,d_qx(:,:,2))
+c
+C
+      if (ok_sync) then
+        call histsync(nid_bilKPave)
+      endif
+       ENDIF
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_bilKP_ins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_bilKP_ins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_bilKP_ins.h	(revision 984)
@@ -0,0 +1,179 @@
+ c
+c $Header$
+c
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ue_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ue",itau_w,ue_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, ve_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ve",itau_w,ve_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, uq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"uq",itau_w,uq_lay)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, vq_lay,zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vq",itau_w,vq_lay)
+c
+c Champs 3D:
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, paprs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"play",itau_w,paprs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"oliq",itau_w,cldliq)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqdyn",itau_w,d_q_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtcon",itau_w,d_t_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"ducon",itau_w,d_u_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvcon",itau_w,d_v_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqcon",itau_w,d_q_con)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlsc",itau_w,d_t_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqlsc",itau_w,d_q_lsc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqvdf",itau_w,d_q_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtajs",itau_w,d_t_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqajs",itau_w,d_q_ajs)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dteva",itau_w,d_t_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqeva",itau_w,d_q_eva)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtswr",itau_w,heat)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtsw0",itau_w,heat0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlwr",itau_w,cool)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtlw0",itau_w,cool0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duvdf",itau_w,d_u_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvvdf",itau_w,d_v_vdf)
+c
+      IF (ok_orodr) THEN
+      IF (ok_orolf) THEN
+c
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = d_u_oro(i,k) + d_u_lif(i,k)
+        d_v_oli(i,k) = d_v_oro(i,k) + d_v_lif(i,k)
+      ENDDO
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duoli",itau_w,d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oli, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvoli",itau_w,d_v_oli)
+c
+      ENDIF
+      ENDIF
+C
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"duphy",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dvphy",itau_w,d_v)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,1), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqphy",itau_w,d_qx(:,:,1))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,2), 
+cym     .zx_tmp_3d)
+      CALL histwrite_phy(nid_bilKPins,"dqlphy",itau_w,d_qx(:,:,2))
+c
+cIM 280405 BEG
+c
+c Champs 2D:
+c
+c   Ecriture de champs dynamiques sur des niveaux de pression
+c     DO k=1, nlevSTD
+      DO k=1, 12
+c
+       IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+       IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c
+       IF(bb2.EQ."850") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_bilKPins,"u"//bb2,itau_w,usumSTD(:,k,1))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_bilKPins,"v"//bb2,itau_w,vsumSTD(:,k,1))
+c
+       ENDIF !(bb2.EQ."850")
+c
+       ENDDO !k=1, 12
+c
+cIM 280405 END
+C
+      if (ok_sync) then
+        call histsync(nid_bilKPins)
+      endif
+       ENDIF
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_field_phy.F90
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_field_phy.F90	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_field_phy.F90	(revision 984)
@@ -0,0 +1,36 @@
+!
+! $Header$
+!
+MODULE write_field_phy
+
+  CONTAINS 
+ 
+    SUBROUTINE WriteField_phy(name,Field,ll)
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE mod_grid_phy_lmdz
+    USE Write_Field
+    
+    IMPLICIT NONE
+    include 'dimensions.h'
+    include 'paramet.h'
+
+    character(len=*)   :: name
+    INTEGER :: ll
+    real, dimension(klon_omp,ll) :: Field
+    real,save,allocatable :: Field_tmp(:,:)
+    real, dimension(klon_glo,ll):: New_Field
+    real, dimension(iim,jjp1,ll):: Field_2d
+
+    CALL Gather(Field,New_Field)
+!$OMP MASTER
+    IF (is_mpi_root) THEN	
+      CALL Grid1Dto2D_glo(New_Field,Field_2D)
+      CALL WriteField(name,Field_2d)
+    ENDIF
+!$OMP END MASTER
+
+  
+   END SUBROUTINE WriteField_phy
+ 
+ END MODULE write_field_phy
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histISCCP.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histISCCP.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histISCCP.h	(revision 984)
@@ -0,0 +1,208 @@
+!
+! $Header$
+!
+      IF (ok_isccp) THEN
+c
+       ndex2d = 0
+       ndex3d = 0
+c
+       itau_w = itau_phy + itap
+c
+       IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+c
+        DO n=1, napisccp
+c
+        DO k=1,kmaxm1
+         zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1,n)*100.
+cym         CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d,
+cym     .                    zx_tmp_3d)
+c
+cIM: champ 3d : (lon,lat,pres) pour un tau fixe
+c
+      CALL histwrite_phy(nid_isccp,"cldISCCP_"//taulev(k)//verticaxe(n),
+     .                  itau_w,zx_tmp_fi3d)
+        ENDDO !k
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),itau_w,
+     .                 nbsunlit(1,:,n))
+c
+        ENDDO ! n=1, napisccp
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+        DO n=1, napisccp
+c        print*,'n=',n,' write_ISCCP avant fq_isccp'
+         DO k=1, kmaxm1
+          DO l=1, lmaxm1
+c
+         IF(top_height.LE.2) THEN
+          DO i=1, klon
+           IF(nbsunlit(1,i,n).NE.0.) THEN
+            fq_is_true(i,k,l,n)=
+     $      fq_isccp(i,k,l,n)*100./nbsunlit(1,i,n)
+           ELSE
+            fq_is_true(i,k,l,n)=0
+           ENDIF
+          ENDDO 
+         ELSE IF(top_height.EQ.3) THEN 
+          DO i=1, klon
+           fq_is_true(i,k,l,n) = fq_isccp(i,k,l,n)*100.
+          ENDDO
+         ENDIF
+cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,fq_is_true,
+cym     .                    zx_tmp_2d)
+c
+cIM: champ 2d : (lon,lat) pour un tau et une pc fixes
+c
+         CALL histwrite_phy(nid_isccp,pclev(l)//taulev(k)//verticaxe(n),
+     .                  itau_w,fq_is_true(:,k,l,n))
+         ENDDO !l
+        ENDDO !k
+c
+c       print*,'n=',n,' write_ISCCP avant nbsunlit'
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),
+     .                 itau_w,nbsunlit(1,:,n))
+c
+        zx_tmp_fi2d(1:klon)=float(seed(1:klon,n))
+c
+c       print*,'n=',n,' write_ISCCP avant seed'
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"seed"//verticaxe(n),
+     .                 itau_w,zx_tmp_fi2d)
+c
+c 9types de nuages ISCCP-D2
+c fq_isccp(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +
+     $  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +
+     $  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+        ENDDO
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cirr",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +
+     $   fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +
+     $   fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cist",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +
+     $   fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +
+     $   fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"deep",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +
+     $  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alcu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +
+     $   fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alst",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +
+     $   fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nist",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +
+     $  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cumu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +
+     $   fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stcu",itau_w,zx_tmp_fi2d)
+c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=
+     $  (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +
+     $   fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO
+cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stra",itau_w,zx_tmp_fi2d)
+c
+c 3_tau_nuages x 3_levels
+c fq_is_true(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         cld_fi3d(i,1)= 
+     $ (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +
+     $  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +
+     $  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+	 cld_fi3d(i,2)=
+     $ (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +
+     $  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+         cld_fi3d(i,3)=
+     $ (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +
+     $  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO   
+cym        CALL gr_fi_ecrit(lmax3,klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thin",itau_w,cld_fi3d)
+c
+        DO i=1, klon
+	 cld_fi3d(i,1)=
+     $   (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +
+     $    fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +
+     $    fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+	 cld_fi3d(i,2)=
+     $   (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +
+     $    fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+	 cld_fi3d(i,3)=
+     $   (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +
+     $    fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+	ENDDO   
+cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"mid",itau_w,cld_fi3d)
+c
+        DO i=1, klon
+	 cld_fi3d(i,1)=
+     $   (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +
+     $    fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +
+     $    fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+         cld_fi3d(i,2)=
+     $   (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +
+     $    fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+	 cld_fi3d(i,3)=
+     $   (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +
+     $    fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO   
+cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thick",itau_w,cld_fi3d)
+c
+        ENDDO ! n=1, napisccp
+c
+       ENDIF
+c
+       if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_isccp)
+c$OMP END MASTER       
+       endif
+
+      ENDIF !ok_isccp
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histREGDYN.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histREGDYN.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histREGDYN.h	(revision 984)
@@ -0,0 +1,63 @@
+!
+! $Header$
+!
+      if (ok_regdyn) then
+      
+      if (is_sequential) then
+
+
+      ndex3d = 0
+      itau_w = itau_phy + itap
+c
+       CALL histwrite(nid_regdyn,"hw1",itau_w,histoW(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh1",itau_w,nhistoW(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht1",itau_w,nhistoWt(:,:,:,1),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw2",itau_w,histoW(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh2",itau_w,nhistoW(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht2",itau_w,nhistoWt(:,:,:,2),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw3",itau_w,histoW(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh3",itau_w,nhistoW(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht3",itau_w,nhistoWt(:,:,:,3),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw4",itau_w,histoW(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh4",itau_w,nhistoW(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht4",itau_w,nhistoWt(:,:,:,4),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"hw5",itau_w,histoW(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nh5",itau_w,nhistoW(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+c
+       CALL histwrite(nid_regdyn,"nht5",itau_w,nhistoWt(:,:,:,5),
+     &               kmaxm1*lmaxm1*iwmax,ndex3d)
+
+      if (ok_sync) then
+        call histsync(nid_regdyn)
+      endif
+
+      endif ! is_sequential
+
+      endif
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histday.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histday.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histday.h	(revision 984)
@@ -0,0 +1,591 @@
+c
+c $Header$
+c
+      if (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         itau_w = itau_phy + itap
+
+c
+      IF(lev_histday.GE.1) THEN
+c
+       CALL histwrite_phy(nid_day,"phis",itau_w,pphis)
+ 
+c
+       CALL histwrite_phy(nid_day,"aire",itau_w,airephy)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"contfracATM",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"contfracOR",itau_w,
+     &                   pctsrf_new(:,is_ter))
+c
+
+      CALL histwrite_phy(nid_day,"dthmin",itau_w,dthmin)
+      CALL histwrite_phy(nid_day,"weakinv",itau_w,weak_inversion)
+
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tsol",itau_w,zxtsol)
+C
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m",itau_w,zt2m)
+c
+c   En attendant un eventuel debugage.
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m_min",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2m_max",itau_w,zt2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_lsc,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowl",itau_w,snow_lsc)
+c
+      IF(1.EQ.0) THEN
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_con,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowc",itau_w,snow_con)
+      ENDIF
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"flat",itau_w,zxfluxlat)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sicf",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10m",itau_w,zv10m)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)     
+      CALL histwrite_phy(nid_day,"wind10m",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"wind10max",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+         zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"snowf",itau_w,snow_fall)
+c
+cIM: 140404   CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite(nid_day,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldt",itau_w,cldt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cldq",itau_w,cldq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"prw",itau_w,prw)
+
+c   Ecriture de champs dynamiques sur des niveaux de pression
+c     DO k=1, nlevENS
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"u"//bb2,itau_w,usumSTD(:,k,1))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,1),zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"v"//bb2,itau_w,vsumSTD(:,k,1))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+c w500
+c
+      IF(bb2.EQ."500") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"w"//bb2,itau_w,wsumSTD(:,k,1))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"phi"//bb2,itau_w,phisumSTD(:,k,1))
+
+      ENDIF !(bb2.EQ."500") THEN
+c
+      ENDDO !nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"cape_max",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"solldown",itau_w,sollwdown)
+c
+      DO i=1, klon
+        zx_tmp_fi2d(i)=-1*sens(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sens",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn(1 : klon, 1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"lmt_bils",itau_w, zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"slab_bils",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"siceh",itau_w,seaice/1000.)
+c
+      ENDIF !(OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      ENDIF !lev_histday.GE.1
+c
+      IF(lev_histday.GE.2) THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"bils",itau_w, bils)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"fder",itau_w,fder)
+c
+      ENDIF !lev_histday.GE.2
+c
+      IF(lev_histday.GE.3) THEN
+c=================================================================
+c   ECRITURE DES CHAMPS 3D
+c=================================================================
+
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"pres",itau_w,pplay)
+c
+      ENDIF !lev_histday.GE.3
+c=================================================================
+c   FIN ECRITURE DES CHAMPS 3D
+c=================================================================
+      IF(lev_histday.ge.4) THEN
+c=================================================================
+c
+c   ECRITURE DES CHAMPS SUR LES SOUS SURFACES
+c
+c=================================================================
+      zx_tmp_fi2d(1 : klon) = swup( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup0( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c 
+      zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c 
+      zx_tmp_fi2d(1 : klon) = swdn0( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM AMMA-MIP
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"LWdnSFC",itau_w,sollwdown)
+c
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+cIM   IF (iflag_con.GE.3) THEN
+cIM ema_pct= 0.     CALL gr_fi_ecrit(1, klon,iim,jjmp1, ema_pct,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, meanptop(:,1),zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"ptop",itau_w,meanptop(:,1))
+cIM   ENDIF
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"toce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tsic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter_min",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mter_max",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"t2msic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10mter",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10mlic",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_oce)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10moce",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"u10msic",itau_w,zx_tmp_fi2d)
+C
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"v10msic",itau_w,zx_tmp_fi2d)
+C
+      DO nsrf = 1, nbsrf
+C
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"pourc_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"fract_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"tsol_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"sens_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C  
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"lat_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"taux_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"tauy_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"albe_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_day,"rugs_"//clnsurf(nsrf),itau_w,
+     $                     zx_tmp_fi2d) 
+C 
+! FH Sorties specifiques pour Mellor et Yamada
+      if (iflag_pbl>1 .and. lev_histday.gt.10 ) then
+
+        CALL histwrite_phy(nid_day,"tke_"//clnsurf(nsrf),itau_w,
+     $      pbl_tke(:,1:klev,nsrf))
+
+        CALL histwrite_phy(nid_day,"tke_max_"//clnsurf(nsrf),itau_w,
+     $      pbl_tke(:,1:klev,nsrf))
+	endif
+
+      END DO  
+c=================================================================
+c   FIN ECRITURE DES CHAMPS SUR LES SOUS SURFACES
+c=================================================================
+      ENDIF !lev_histday.GE.4
+c
+      IF(lev_histday.GE.5) THEN !lev_histday.GE.5
+c
+c rajout sorties F. Aires
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"topl0",itau_w,toplw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"soll0",itau_w, sollw0)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"rneb",itau_w,cldfra)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"iwcon",itau_w,fiwc)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, meantaucld,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"meantaucld",itau_w,meantaucld)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldtau,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"cldtau",itau_w,cldtau)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldemi,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"cldemi",itau_w,cldemi)
+c
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"dtcon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_day,"dqcon",itau_w,zx_tmp_fi3d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, zx_tmp_2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"rh2m",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, qsat2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"qsat2m",itau_w,qsat2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, tpot,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tpot",itau_w,tpot)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1, tpote,zx_tmp_2d)
+      CALL histwrite_phy(nid_day,"tpote",itau_w,tpote)
+c
+      ENDIF !lev_histday.GE.5
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_day)
+c$OMP END MASTER
+      endif
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histday_seri.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histday_seri.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histday_seri.h	(revision 984)
@@ -0,0 +1,242 @@
+c
+c $Header$
+c
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+c
+      ndex2d = 0
+      itau_w = itau_phy + itap
+c
+c Champs 2D:
+c
+      pi = ACOS(-1.)
+      pir = 4.0*ATAN(1.0) / 180.0
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=(topsw(i)-toplw(i))
+      ENDDO
+c
+      ok_msk=.FALSE.
+      msk(1:klon)=pctsrf(1:klon,is_ter)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bilTOA",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, bils, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bils",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO k=1, klev
+      DO i=1, klon
+cIM 080904    zx_tmp_fi3d(i,k)=u(i,k)**2+v(i,k)**2
+       zx_tmp_fi3d(i,k)=(u(i,k)**2+v(i,k)**2)/2.
+      ENDDO
+      ENDDO
+c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, 
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"ecin",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+cIM 151004 BEG
+      IF(1.EQ.0) THEN
+c
+      DO k=1, klev
+      DO i=1, klon
+       zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i))
+      ENDDO
+      ENDDO
+c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d, 
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+c friction torque
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i))
+      ENDDO
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+c mountain torque
+c
+cIM 190504 BEG
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_dyn(klev+1,klon,iim+1,jjm+1,paprs,padyn)
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,rlat,rlatdyn)
+      mountor=0.
+      airetot=0.
+      DO j = 1, jjmp1
+       DO i = 1, iim+1
+        ij=i+(iim+1)*(j-1)
+        zx_tmp(ij)=0.
+        DO k = 1, klev
+         zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)*
+     $              (padyn(i,j,k+1)-padyn(i,j,k))/RG
+         airetot=airetot+airedyn(i,j)
+        ENDDO
+cIM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA*
+        mountor=mountor+zx_tmp(ij)*RA*
+     $           cos(pir* rlatdyn(i,j))
+       ENDDO
+      ENDDO
+cIM 151004 BEG
+      IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev
+cIM 151004 END
+cIM 190504      mountor=mountor/(airetot*airetot)
+      mountor=mountor/airetot
+c
+cIM 190504 END
+      zx_tmp_2d(1:iim,1:jjmp1)=mountor
+      CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      ENDIF !(1.EQ.0) THEN
+c
+c
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      airetot=0.
+c     DO j = 1, jjmp1
+c      DO i = 1, iim+1
+c       ij=i+(iim+1)*(j-1)
+c       DO k = 1, klev
+c        airetot=airetot+airedyn(i,j)
+c        airetot=airetot+airedyn(i,j)
+c       ENDDO !k
+c      ENDDO !i
+c     ENDDO !j
+c
+      DO i=1, klon
+       airetot=airetot+airephy(i)
+      ENDDO
+c     IF(itap.EQ.1) PRINT*,'airetotphy=',airetot
+c
+      airetot=0.
+      DO j=1, jjmp1
+       DO i=1, iim
+        airetot=airetot+zx_tmp_2d(i,j)
+       ENDDO
+      ENDDO
+c
+c     IF(itap.EQ.1) PRINT*,'airetotij=',airetot,
+c    $ '4piR2',4.*pi*RA*RA
+c
+      zx_tmp_fi2d(1:klon)=aam/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1:klon)=torsfc/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"torsfc",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+cIM 151004 END
+c
+      CALL moyglo_pondmass(klon, klev, t_seri,
+     .     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tamv",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, paprs(:,1), airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"psol",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, evap, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"evap",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c     DO i=1, klon
+c      zx_tmp_fi2d(i)=SnowFrac(i,is_ter)
+c     ENDDO
+c
+c     ok_msk=.TRUE.
+c     msk(1:klon)=pctsrf_new(1:klon,is_ter)
+c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+c    .                     ok_msk, msk, moyglo)
+c     zx_tmp_fi2d(1:klon)=moyglo
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+c     CALL histwrite(nid_day_seri,"SnowFrac",
+c    .               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+c     DO i=1, klon
+cIM 080904    zx_tmp_fi2d(i)=zsnow_mass(i)/330.*rowl
+c      zx_tmp_fi2d(i)=zsnow_mass(i)
+c     ENDDO
+c
+cIM 140904   ok_msk=.FALSE.
+c     ok_msk=.TRUE.
+c     msk(1:klon)=pctsrf(1:klon,is_ter)
+c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+c    .     ok_msk, msk, moyglo)
+c     zx_tmp_fi2d(1:klon)=moyglo
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+c     CALL histwrite(nid_day_seri,"snow_depth",itau_w,
+c    .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=ftsol(i,is_oce)
+      ENDDO
+c
+      ok_msk=.TRUE.
+      msk(1:klon)=pctsrf(1:klon,is_oce)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+     .     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tsol_"//clnsurf(is_oce),
+     $               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_day_seri)
+      endif
+c
+      ENDIF !fin test sur type_run.EQ."AMIP"
+      
+      ENDIF  ! mono_cpu
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histhf.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histhf.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histhf.h	(revision 984)
@@ -0,0 +1,356 @@
+!
+! $Header$
+!
+      if (ok_hf) then
+
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, paire_ter, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"aireTER",itau_w,paire_ter)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"contfracATM",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pctsrf_new(:,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"contfracOR",itau_w,
+     .                   pctsrf_new(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t2m",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q2m",itau_w,zq2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"precip",itau_w,zx_tmp_fi2d)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"slp",itau_w,slp)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v10m",itau_w,zv10m)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."500") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w, philevSTD(:,k))
+      ENDIF !bb2.EQ."500"
+      ENDDO
+c
+      ENDIF !lev_histhf.GE.1
+c
+      IF(lev_histhf.GE.2) THEN
+c
+cIM 140904 BEG
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = cldt(i)*100.
+      ENDDO
+cIM 140904 END
+cIM 140904   CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cldt",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"SWnetOR",itau_w, zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol(1:klon))
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"SWdownOR",itau_w, zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWdownOR",itau_w,sollwdown) 
+c
+c
+      ENDIF !lev_histhf.GE.2
+c
+      IF(lev_histhf.GE.3) THEN
+c
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t"//bb2,itau_w, tlevSTD(:,k))
+c
+      IF(bb2.NE."500") THEN !bb2.NE."500"
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,philevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w,philevSTD(:,k))
+      ENDIF !bb2.NE."500"
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q"//bb2,itau_w, qlevSTD(:,k))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u"//bb2,itau_w,ulevSTD(:,k))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v"//bb2,itau_w, vlevSTD(:,k))
+c
+      ENDIF !bb2.EQ."850".OR.bb2.EQ."700"
+      ENDDO !nlevENS
+c
+      IF(1.EQ.0) THEN
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cdrh",itau_w,cdragh)
+      ENDIF !(1.EQ.0) THEN
+c
+      ENDIF !lev_histhf.GE.3
+c
+      IF(lev_histhf.GE.4) THEN 
+c
+#undef histhf3d
+#define histhf3d
+#ifdef histhf3d
+#include "write_histhf3d.h"
+#endif
+c
+      ENDIF !lev_histhf.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histhf.GE.1) THEN
+c
+      DO k=1, nlevSTD
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+        IF(bb2.EQ."850".or.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"u"//bb2,itau_w,ulevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"v"//bb2,itau_w,vlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."850".or.bb2.EQ."200"
+c
+      ENDDO !nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"topl",itau_w,toplw)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"slp",itau_w,slp)
+c
+cIM 280504 BEG
+      ENDIF !(lev_histhf.GE.1) THEN
+c
+      IF(lev_histhf.GE.2) THEN
+c
+       DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+        IF(bb2.EQ."850".or.bb2.EQ."500") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"t"//bb2,itau_w,tlevSTD(:,k))
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, qlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"q"//bb2,itau_w, qlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."850".or.bb2.EQ."500"
+c
+        IF(bb2.EQ."500") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, philevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"phi"//bb2,itau_w, philevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, wlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"w"//bb2,itau_w, wlevSTD(:,k))
+c
+        ENDIF !bb2.EQ."500"
+c
+        IF(bb3.EQ."50") THEN
+c
+cym         CALL gr_fi_ecrit(1, klon,iim,jjmp1, tlevSTD(:,k),zx_tmp_2d)
+         CALL histwrite_phy(nid_hf,"t"//bb3,itau_w, tlevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, ulevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"u"//bb3,itau_w, ulevSTD(:,k))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, vlevSTD(:,k),zx_tmp_2d)
+        CALL histwrite_phy(nid_hf,"v"//bb3,itau_w, vlevSTD(:,k))
+c
+        ENDIF !bb3.EQ."50"
+c
+       ENDDO !k=1, nlevSTD
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"u10m",itau_w,zu10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"v10m",itau_w,zv10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"t2m",itau_w, zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"q2m",itau_w,zq2m)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"psol",itau_w,zx_tmp_fi2d)
+c
+cIM 140904 BEG
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = cldt(i)*100.
+      ENDDO
+cIM 140904 END
+cIM 140904   CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"cldt",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = zxfluxu(1 : klon, 1)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"taux",itau_w,zx_tmp_fi2d)
+C
+      zx_tmp_fi2d(1 : klon) = zxfluxv(1 : klon, 1)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"tauy",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"prw",itau_w,prw)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"flat",itau_w,zxfluxlat)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_hf,"snow_mass",itau_w,zsnow_mass)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWdnSFC",itau_w,sollwdown)
+c
+cIM 090904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_hf,"LWupSFC",itau_w,zx_tmp_fi2d)                    
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_hf, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+      IF (is_sequential) THEN
+cym      CALL gr_fi_ecrit(nbteta,klon,iim,jjmp1,PVteta,zx_tmp_3dte)
+      DO k=1, nbteta
+       zx_tmp_fi2d(1:klon) = PVteta(1:klon,k)
+       CALL histwrite_phy(nid_hf,"PV"//ctetaSTD(k),
+     .      itau_w,zx_tmp_fi2d)
+      ENDDO !k=1, nbteta
+      ENDIF
+c
+c
+c planetary boundary layer height
+c
+c     ENDIF !1.EQ.0
+c
+      ENDIF !(lev_histhf.GE.2) THEN
+cIM 280504 END
+c
+      ENDIF !type_run
+c
+      IF (ok_sync) THEN
+c$OMP MASTER
+        call histsync(nid_hf)
+c$OMP END MASTER
+      ENDIF
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histhf3d.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histhf3d.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histhf3d.h	(revision 984)
@@ -0,0 +1,28 @@
+
+c
+c $Header$
+c
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + itap
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"ovap",itau_w,qx(:,:,ivap))
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_hf3d,"vitv",itau_w,v_seri)
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_hf3d)
+c$OMP END MASTER      
+      endif
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histins.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histins.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histins.h	(revision 984)
@@ -0,0 +1,234 @@
+!
+! $Header$
+!
+      IF (ok_instan) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+      itau_w = itau_phy + itap
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"phis",itau_w,pphis)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"aire",itau_w,airephy)
+
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"psol",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"precip",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)    
+      CALL histwrite_phy(nid_ins,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"pluc",itau_w,zx_tmp_fi2d)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"tsol",itau_w,zxtsol)
+cccIM
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"t2m",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m, zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"v10m",itau_w,zv10m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"snow",itau_w,snow_fall)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"solldown",itau_w,sollwdown)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"fder",itau_w,fder)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfo",itau_w,d_ts(:,is_oce))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdft",itau_w,d_ts(:,is_ter))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfg",itau_w, d_ts(:,is_lic))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"dtsvdfi",itau_w,d_ts(:,is_sic))
+
+      DO nsrf = 1, nbsrf
+CXXX
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"pourc_"//clnsurf(nsrf),itau_w,
+     $                zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"tauy_"//clnsurf(nsrf),itau_w,
+     $     zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_ins,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C 
+      END DO  
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"albs",itau_w,albsol)
+      
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"albslw",itau_w,albsollw)
+
+c
+cIM: 140404   CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_ins,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"rugs",itau_w,zxrugs)
+c
+cIM cf. AM 081204 BEG
+c
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_ins,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c Champs 3D:
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"temp",itau_w,t_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"dtvdf",itau_w,d_t_vdf)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite_phy(nid_ins,"dqvdf",itau_w,d_q_vdf)
+
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_ins)
+c$OMP END MASTER
+      endif
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histmth.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histmth.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histmth.h	(revision 984)
@@ -0,0 +1,1906 @@
+c
+c $Header$
+c
+      IF (ok_mensuel) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+
+         itau_w = itau_phy + itap
+
+c
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+c Champs 2D:
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phis",itau_w,pphis)
+C
+cIM 310804   CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"aire",itau_w,airephy)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_ter),itau_w,
+     $                   zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m",itau_w,zt2m)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_min",itau_w,zt2m)
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_max",itau_w,zt2m)
+c
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"tsoil",itau_w,zx_tmp_2d,
+c    .               iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sicf",itau_w,zx_tmp_fi2d)
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"temp",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+c ENSEMBLES END
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"v10m",itau_w,zv10m)
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"psol",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"qsurf",itau_w,zxqsurf)
+c
+      if (.not. ok_veget) then
+cym          CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d)
+          CALL histwrite_phy(nid_mth,"qsol",itau_w,qsol)
+      endif
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ndayrain",itau_w,nday_rain)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"snow",itau_w,snow_fall)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl0",itau_w,toplw0)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+c
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200",itau_w,SWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200clr",itau_w,SWup200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200",itau_w,SWdn200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200clr",itau_w,SWdn200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200",itau_w,LWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200clr",itau_w,LWup200clr)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200clr",itau_w,zx_tmp_fi2d)
+c
+c200 END 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll0",itau_w,sollw0)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       sollwdownclr(i)=-1.*lwdn0(i,1)
+      ENDDO !i=1, klon
+
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)-sollwdownclr(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFC",itau_w,sollwdown)
+c
+c     DO i=1, klon
+cIM 080904     sollwdownclr(i)=lwdn0(i,1)
+c      sollwdownclr(i)=-1.*lwdn0(i,1)
+c     ENDDO !i=1, klon
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFCclr",itau_w,sollwdownclr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fder",itau_w,fder)
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"ffonte",itau_w,zxffonte)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqcalving",itau_w,zxfqcalving)
+
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqfonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqfonte",itau_w,zxfqfonte)
+
+       DO nsrf = 1, nbsrf
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDDO
+c
+      DO nsrf = 1, nbsrf
+CYYY
+       IF(nsrf.GT.2) THEN
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(nsrf),itau_w,
+     &                     zx_tmp_fi2d) 
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fract_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+       ENDIF !nsrf.GT.2
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       IF(1.EQ.0) THEN
+C
+        zx_tmp_fi2d(1:klon) = fevap(1:klon,nsrf)*pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"evapour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1:klon) = (rain_fall(1:klon) + snow_fall(1:klon))
+     $                        *pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"prepour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       ENDIF !(1.EQ.0) THEN
+C
+      END DO  
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldt",itau_w,cldt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldq",itau_w,cldq)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ue",itau_w,ue)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ve",itau_w,ve)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"uq",itau_w,uq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"vq",itau_w,vq)
+cKE43
+      IF (iflag_con.GE.3) THEN ! sb
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cape",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pbase",itau_w,pbase)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ptop",itau_w,ema_pct)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fbase",itau_w,ema_cbmf)
+c
+c34EK
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"prw",itau_w,prw)
+c
+      ENDIF !iflag_con.GE.3
+c
+c
+cIM cf. AM 081204 BEG
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c  Champs interpolles sur des niveaux de pression
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.
+     $   bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"u"//bb2,itau_w,usumSTD(:,k,2))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"v"//bb2,itau_w,vsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"w"//bb2,itau_w,wsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phi"//bb2,itau_w,phisumSTD(:,k,2))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+      ENDDO !nlevSTD
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     .     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ 
+     .                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     .                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t_oce_sic",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lmt_bils",itau_w,zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slab_bils",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"siceh",itau_w, seaice/1000.)
+c
+      ENDIF !OCEAN.EQ.force/slab
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+C
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"iwcon",itau_w,fiwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"temp",itau_w,t_seri)
+c
+c#ifdef histmthNMC
+c#include "write_histmthNMC.h"
+c#endif
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ovap",itau_w,qx(:,:,ivap))
+c
+c     zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/
+c    .                         (1-qx(1:klon,1:klev,ivap))
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+c     CALL histwrite(nid_mth,"wvap",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rneb",itau_w,cldfra)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rhum",itau_w,zx_rh)
+
+      DO k=1, klev
+       DO i=1, klon
+cIM 151004      zx_tmp_fi3d(i,k)=MAX(wo(i,k),1.0e-12)*RG/46.6968
+c    $                    /(paprs(i,k)-paprs(i,k+1))
+c    $                    *(paprs(i,1)/101325.0)
+c        zx_tmp2_fi3d(i,k)=MAX(wo(i,k)*1.0e+6,1.0e-6)*RG/46.6968
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp2_fi3d,zx_tmp_3d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ozone",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap), 
+cym     .                 zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqphy",itau_w, d_qx(:,:,ivap))
+cIM 22.03.04 END
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+       DO nsrf=1, nbsrf
+c
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ages_"//clnsurf(nsrf),itau_w
+     $    ,zx_tmp_fi2d)
+c
+      ENDDO !nsrf=1, nbsrf
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albs",itau_w,albsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albslw",itau_w,albsollw)
+c
+      ENDIF !lev_histmth.GE.3
+c
+c
+      IF(lev_histmth.GE.4) THEN
+c
+c  FH Sorties pour la couche limite
+      CALL histwrite_phy(nid_mth,"kz",itau_w,ycoefh)
+      CALL histwrite_phy(nid_mth,"kz_max",itau_w,ycoefh)
+
+      if(iflag_pbl>1) then
+      zx_tmp_fi3d=0.
+      do nsrf=1,nbsrf
+         do k=1,klev
+          zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k)
+     ,    +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+         enddo
+      enddo
+      CALL histwrite_phy(nid_mth,"tke",itau_w,zx_tmp_fi3d)
+      CALL histwrite_phy(nid_mth,"tke_max",itau_w,zx_tmp_fi3d)
+      endif
+
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"clwcon",itau_w,clwcon0)
+
+      IF (iflag_con.GE.3) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"Ma",itau_w,Ma)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"upwd",itau_w,upwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd",itau_w,dnwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd0",itau_w,dnwd0)
+c
+      ENDIF !iflag_con.GE.3
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdyn",itau_w,d_q_dyn)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtcon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqcon",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlsc",itau_w,zx_tmp_fi3d)
+cIM: 071003
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     .                             d_t_eva(1:klon,1:klev))/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlschr",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqlsc",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqvdf",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dteva",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqeva",itau_w,zx_tmp_fi3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ptconv",itau_w,zpt_conv)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ratqs",itau_w,ratqs)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtajs",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqajs",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtthe",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqthe",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY 
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtswr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlwr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : deja en K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtec",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvvdf",itau_w,zx_tmp_fi3d)
+c
+      IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoro",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoro",itau_w,zx_tmp_fi3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dulif",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvlif",itau_w,zx_tmp_fi3d)
+      ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      CALL histwrite_phy(nid_mth,"tau",itau_w,cldtau)
+      CALL histwrite_phy(nid_mth,"CCM1",itau_w,ccm(:,:,1))
+      CALL histwrite_phy(nid_mth,"CCM2",itau_w,ccm(:,:,2))
+      CALL histwrite_phy(nid_mth,"taupi",itau_w,cldtaupi)
+      CALL histwrite_phy(nid_mth,"cldemi",itau_w,cldemi)
+      CALL histwrite_phy(nid_mth,"SWTOAAS_ZERO",itau_w,topsw_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AER",itau_w,topsw_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_NAT",itau_w,topsw_inca(:,3))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AD",itau_w,topswad_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AI",itau_w,topswai_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_ZERO",itau_w,topsw0_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AER",itau_w,topsw0_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AD",itau_w,topswad0_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_NAT",itau_w,topsw0_inca(:,3))
+#endif
+#ifndef INCA
+      IF (nqmax.GE.3) THEN
+      DO iq=3,nqmax
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq), zx_tmp_3d)
+         CALL histwrite_phy(nid_mth,tnom(iq),itau_w,qx(:,:,iq))
+      ENDDO
+      ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+c
+      IF(lev_histmth.GE.1) THEN
+c
+c Champs 2D:
+c
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis/RG,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phis",itau_w,pphis/RG)
+C
+cIM 310804   CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"aire",itau_w,airephy)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_ter),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_ter)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_ter),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_lic)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_lic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_lic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_lic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_sic)* 100.
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_sic),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = pctsrf(1 : klon, is_sic)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_sic),itau_w,
+     $      zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfluxlat,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"flat",itau_w,zxfluxlat)
+c
+      zx_tmp_fi2d(1 : klon) = topsw(1:klon)-toplw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bilTOA",itau_w,zx_tmp_fi2d)
+c
+c     IF(itap.EQ.ecrit_mth) THEN
+c       DO i=1, klon
+c         IF(nday_clr(i).GT.0.) THEN
+c          tops01(i)=tops01(i)/nday_clr(i)
+c         ELSE
+c          tops01(i)=1.e+20
+c         ENDIF
+c       ENDDO
+c       CALL gr_fi_ecrit(1, klon,iim,jjmp1, tops01,zx_tmp_2d)
+c       CALL histwrite_phy(nid_mth,"tops01",itau_w,zx_tmp_2d,
+c    .       iim*jjmp1,ndex2d)
+c     ENDIF !itap.EQ.ecrit_mth 
+c
+c220404 BEG
+c
+c temperature tendency due to total diabatic heating
+       DO l=1, klev
+       DO i=1, klon
+       d_t(i,l) = (t_seri(i,l)-t(i,l))/dtime
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdia",itau_w,d_t)
+c
+c temperature tendency due to SW radiation
+       DO l=1, klev
+       DO i=1, klon
+       zx_tmp_fi3d(i,l)=heat(i,l)/RDAY
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw",itau_w,zx_tmp_fi3d)
+c
+c temperature tendency due to LW radiation
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=-1*cool(i,l)/RDAY
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw",itau_w,zx_tmp_fi3d)
+c
+c  temperature tendency due to moist convective processes
+       DO l=1, klev
+       DO i=1, klon
+        zx_tmp_fi3d(i,l)=d_t_con(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtcon",itau_w,zx_tmp_fi3d)
+c
+
+
+
+
+c
+c  temperature tendency due to large scale precipitation
+       DO l=1, klev
+       DO i=1, klon
+       zx_tmp_fi3d(i,l)=d_t_lsc(i,l)/pdtphys
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlsc",itau_w,zx_tmp_fi3d)
+c
+c  total moisture tendency due to diabatic processes
+       DO l=1, klev
+       DO i=1, klon
+        d_qx(i,l,ivap) = ( q_seri(i,l) - qx(i,l,ivap) ) / dtime
+        zx_tmp_fi3d(i,l)=d_qx(i,l,ivap)
+       ENDDO !i
+       ENDDO !l
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1, zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdia",itau_w,zx_tmp_fi3d)
+c
+cBEG 210404 BEG
+c
+      IF(ok_orodr.AND.ok_orolf) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+        d_u_oli(i,k) = (d_u_oro(i,k) + d_u_lif(i,k))/pdtphys
+        d_v_oli(i,k) = (d_v_oro(i,k) + d_v_lif(i,k))/pdtphys
+      ENDDO
+      ENDDO
+      ENDIF !(ok_orodr.AND.ok_orolf) THEN
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_u_oli,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoli",itau_w,d_u_oli)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_v_oli,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoli",itau_w,d_v_oli)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ducon",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvcon",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_u,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dutot",itau_w,d_u)
+c
+cym      CALL gr_fi_ecrit(klev, klon,iim,jjmp1,d_v,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvtot",itau_w,d_v)
+
+cEND 210404 END
+c
+c cldtrue
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldtrue,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldtrue",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldTOA,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldTOA",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+c     CALL gr_fi_ecrit(klev, klon,iim,jjmp1,cldSFC,zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"cldSFC",itau_w,zx_tmp_3d,
+c    $       iim*jjmp1*klev,ndex3d)
+c
+      DO i=1, klon
+cIM 151004    zx_tmp_fi2d(i)=GWDtaux1(i,1)-GWDtaux0(i,1)
+       zx_tmp_fi2d(i)=zustrdr(i)+zustrli(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"GWDtaux",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+cIM 151004    zx_tmp_fi2d(i)=GWDtauy1(i,1)-GWDtauy0(i,1)
+       zx_tmp_fi2d(i)=zvstrdr(i)+zvstrli(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"GWDtauy",itau_w,zx_tmp_fi2d)
+c
+c220404 END
+cAMIP2 END
+c
+cym     CALL gr_fi_ecrit(1, klon,iim,jjmp1, slp,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slp",itau_w,slp)
+
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tsol",itau_w,zxtsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m",itau_w,zt2m)
+c
+c ENSEMBLES BEG
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_min",itau_w,zt2m)
+c
+cym     CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t2m_max",itau_w,zt2m)
+c
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsoil(:,1,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ftsol(:,is_ter),zx_tmp_2d)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,ztsol,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"tsoil",itau_w,zx_tmp_2d,
+c    .               iim*jjmp1,ndex2d)
+c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"wind10m",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sicf",itau_w,zx_tmp_fi2d)
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"temp",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+c ENSEMBLES END
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"q2m",itau_w,zq2m)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"u10m",itau_w,zu10m)
+C
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"v10m",itau_w,zv10m)
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"psol",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsurf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"qsurf",itau_w,zxqsurf)
+c
+      if (.not. ok_veget) then
+cym          CALL gr_fi_ecrit(1, klon,iim,jjmp1, qsol,zx_tmp_2d)
+          CALL histwrite_phy(nid_mth,"qsol",itau_w,qsol)
+      endif
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"precip",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, nday_rain,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ndayrain",itau_w,nday_rain)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"plul",itau_w,zx_tmp_fi2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pluc",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"snowf",itau_w,snow_fall)
+c
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, zsnow_mass,zx_tmp_2d)
+c     CALL histwrite_phy(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+c    .               ndex2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"evap",itau_w,evap)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops",itau_w,topsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tops0",itau_w,topsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl",itau_w,toplw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"topl0",itau_w,toplw0)
+c
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOA",itau_w,zx_tmp_fi2d)
+c
+c
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupTOAclr",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOA",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnTOAclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200",itau_w,SWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWup200clr",itau_w,SWup200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200",itau_w,SWdn200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, SWdn200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"SWdn200clr",itau_w,SWdn200clr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200",itau_w,LWup200)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, LWup200clr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWup200clr",itau_w,LWup200clr)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon)=-1*LWdn200clr(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdn200clr",itau_w,zx_tmp_fi2d)
+c
+c200 END 
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols",itau_w,solsw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sols0",itau_w,solsw0)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll",itau_w,sollw)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, radsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"radsol",itau_w,radsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"soll0",itau_w,sollw0)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSUP0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFC",itau_w,zx_tmp_fi2d)
+c
+c      zx_tmp_fi2d(1 : klon) = ZFSDN0( 1 : klon, 1)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+cym      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth, "SWdnSFCclr",itau_w,zx_tmp_fi2d)
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw(1:klon)+sollwdown(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw(1:klon)-sollwdown(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFC",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       sollwdownclr(i)=-1.*lwdn0(i,1)
+      ENDDO !i=1, klon
+c
+cIM 080904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)+sollwdownclr(1:klon)
+cIM 130904   zx_tmp_fi2d(1:klon)=sollw0(1:klon)-sollwdownclr(1:klon)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWupSFCclr",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFC",itau_w,sollwdown)
+c
+c     DO i=1, klon
+cIM 08004    sollwdownclr(i)=lwdn0(i,1)
+c      sollwdownclr(i)=-1.*lwdn0(i,1)
+c     ENDDO !i=1, klon
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdownclr,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"LWdnSFCclr",itau_w,sollwdownclr)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"bils",itau_w,bils)
+c
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+c     CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"sens",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fder",itau_w,fder)
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite_phy(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite_phy(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxffonte,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"ffonte",itau_w,zxffonte)
+c
+cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxfqcalving,zx_tmp_2d)
+       CALL histwrite_phy(nid_mth,"fqcalving",itau_w,zxfqcalving)
+c
+       DO nsrf = 1, nbsrf
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+       ENDDO
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_oce)*100.
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"pourc_"//clnsurf(is_oce),itau_w,
+     $      zx_tmp_fi2d) 
+c
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, is_oce)
+cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fract_"//clnsurf(is_oce),itau_w,
+     $      zx_tmp_fi2d) 
+c
+      DO nsrf = 1, nbsrf
+CYYY
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"flw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"fsw_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbils_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"wbilo_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       IF(1.EQ.0) THEN
+C
+        zx_tmp_fi2d(1:klon) = fevap(1:klon,nsrf)*pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"evapour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1:klon) = (rain_fall(1:klon) + snow_fall(1:klon))
+     $                        *pctsrf(1:klon,nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"prepour_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+       ENDIF !(1.EQ.0) THEN
+C
+      END DO  
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrm",itau_w,cdragm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cdrh",itau_w,cdragh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldl",itau_w,cldl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldm",itau_w,cldm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldh",itau_w,cldh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt*100.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldt",itau_w,cldt*100.)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cldq",itau_w,cldq)
+c
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lwp",itau_w,zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"iwp",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ue",itau_w,ue)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ve",itau_w,ve)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"uq",itau_w,uq)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"vq",itau_w,vq)
+cKE43
+      IF (iflag_con.GE.3) THEN ! sb
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"cape",itau_w,cape)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"pbase",itau_w,pbase)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ptop",itau_w,ema_pct)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fbase",itau_w,ema_cbmf)
+c
+c34EK
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, prw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"prw",itau_w,prw)
+c
+      ENDIF !iflag_con.GE.3
+c
+cIM cf. AM 081204 BEG
+cHBTM2
+c
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblh,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblh",itau_w,s_pblh)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_pblt,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_pblt",itau_w,s_pblt)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_lcl,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_lcl",itau_w,s_lcl)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_capCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_capCL",itau_w,s_capCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_oliqCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_oliqCL",itau_w,s_oliqCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_cteiCL,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_cteiCL",itau_w,s_cteiCL)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_therm,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_therm",itau_w,s_therm)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb1,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb1",itau_w,s_trmb1)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb2,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb2",itau_w,s_trmb2)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, s_trmb3,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"s_trmb3",itau_w,s_trmb3)
+c
+cIM cf. AM 081204 END
+c
+c  Champs interpolles sur des niveaux de pression
+c     DO k=1, nlevENS
+      DO k=1, nlevSTD
+c
+c        bb=clevSTD(k)
+c
+c        IF(k.GE.2) THEN
+         IF(k.GE.2.AND.k.LE.12) bb2=clevSTD(k)
+         IF(k.GE.13.AND.k.LE.17) bb3=clevSTD(k)
+c         aa=clevSTD(k)
+c         bb=aa(1:lnblnk1(aa))
+c        ENDIF
+c
+       IF(bb2.EQ."850".OR.bb2.EQ."700"
+     $   .OR.bb2.EQ."500".OR.bb2.EQ."200") THEN
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,usumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"u"//bb2,itau_w,usumSTD(:,k,2))
+c
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,vsumSTD(:,k,2),zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"v"//bb2,itau_w,vsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,wsumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"w"//bb2,itau_w,wsumSTD(:,k,2))
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1,phisumSTD(:,k,2),zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"phi"//bb2,itau_w,phisumSTD(:,k,2))
+c
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700"
+      ENDDO !nlevSTD
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxo(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxo",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = fluxg(i)
+       ELSE
+        zx_tmp_fi2d(i) = 0.
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"fluxg",itau_w,zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.
+     .     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+ 
+     .                   ftsol(i, is_sic) * pctsrf(i,is_sic))/
+     .                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"t_oce_sic",itau_w,zx_tmp_fi2d)
+c
+      IF (OCEAN.EQ.'force ') THEN
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"lmt_bils",itau_w,
+     .     zx_tmp_fi2d)
+c
+      ELSE IF (OCEAN.EQ.'slab  ') THEN
+c
+c
+      DO i=1, klon
+      IF((pctsrf(i,is_oce).GT.epsfra).OR.
+     .   (pctsrf(i,is_sic).GT.epsfra)) THEN
+       zx_tmp_fi2d(i) = (radsol(i) + fluxo(i))*pctsrf(i,is_oce)+
+     .                  fluxg(i)*pctsrf(i,is_sic)
+      ELSE
+       zx_tmp_fi2d(i) = 1.E+20
+      ENDIF
+      ENDDO
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"slab_bils",itau_w,
+     .     zx_tmp_fi2d)
+c
+      DO i=1, klon
+       IF(pctsrf(i,is_oce).GT.epsfra.OR.
+     $    pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i)=tslab(i)
+       ELSE
+        zx_tmp_fi2d(i) = 1.E+20
+       ENDIF
+      ENDDO !i=1, klon
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"tslab",itau_w,zx_tmp_fi2d)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"seaice",itau_w,seaice)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, seaice/1000.,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"siceh",itau_w,seaice/1000.)
+c
+      ENDIF !OCEAN.EQ.force/slab
+c
+      ENDIF !lev_histmth.GE.1
+c
+      IF(lev_histmth.GE.2) THEN
+c
+c Champs 3D:
+C
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, flwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"lwcon",itau_w,flwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, fiwc,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"iwcon",itau_w,fiwc)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"temp",itau_w,t_seri)
+c
+c#ifdef histmthNMC
+c#include "write_histmthNMC.h"
+c#endif
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ovap",itau_w, qx(:,:,ivap))
+c
+c     zx_tmp_fi3d(1:klon,1:klev)=qx(1:klon,1:klev,ivap)/
+c    .                         (1-qx(1:klon,1:klev,ivap))
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+c     CALL histwrite_phy(nid_mth,"wvap",itau_w,zx_tmp_3d,
+c    .                                   iim*jjmp1*klev,ndex3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"geop",itau_w,zphi)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitu",itau_w,u_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitv",itau_w,v_seri)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"vitw",itau_w,omega)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"pres",itau_w,pplay)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra*100., zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rneb",itau_w,cldfra*100.)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, rnebcon, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rnebcon",itau_w,rnebcon)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"rhum",itau_w,zx_rh)
+c
+      DO k=1, klev
+       DO i=1, klon
+cIM 151004        zx_tmp_fi3d(i,k)=MAX(wo(i,k),1.0e-12)*RG/46.6968
+c    $                    /(paprs(i,k)-paprs(i,k+1))
+c    $                    *(paprs(i,1)/101325.0)
+c        zx_tmp2_fi3d(i,k)=MAX(wo(i,k)*1.0e+6,1.0e-6)*RG/46.6968
+         zx_tmp_fi3d(i,k)=wo(i,k)*RG/46.6968
+     $                    /(paprs(i,k)-paprs(i,k+1))
+     $                    *(paprs(i,1)/101325.0)
+       ENDDO !i
+      ENDDO !k
+c
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+c     CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp2_fi3d,zx_tmp_3d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ozone",itau_w,zx_tmp_fi3d)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtphy",itau_w,d_t)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_qx(:,:,ivap),zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqphy",itau_w,d_qx(:,:,ivap))
+c
+      ENDIF !lev_histmth.GE.2
+c
+      IF(lev_histmth.GE.3) THEN
+c
+       DO nsrf=1, nbsrf
+c
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite_phy(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
+     $      zx_tmp_fi2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"ages_"//clnsurf(nsrf),itau_w
+     $    ,agesno)
+c
+      ENDDO !nsrf=1, nbsrf
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albs",itau_w,albsol)
+c
+cym      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite_phy(nid_mth,"albslw",itau_w,albsollw)
+c
+      ENDIF !lev_histmth.GE.3
+c
+c
+      IF(lev_histmth.GE.4) THEN
+c
+c  FH Sorties pour la couche limite
+      CALL histwrite_phy(nid_mth,"kz",itau_w,ycoefh)
+      CALL histwrite_phy(nid_mth,"kz_max",itau_w,ycoefh)
+
+      if(iflag_pbl>1) then
+      zx_tmp_fi3d=0.
+      do nsrf=1,nbsrf
+         do k=1,klev
+          zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k)
+     ,    +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+         enddo
+      enddo
+      CALL histwrite_phy(nid_mth,"tke",itau_w,zx_tmp_fi3d)
+      CALL histwrite_phy(nid_mth,"tke_max",itau_w,zx_tmp_fi3d)
+      endif
+
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"clwcon",itau_w,clwcon0)
+c
+      IF (iflag_con.GE.3) THEN
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"Ma",itau_w,Ma)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"upwd",itau_w,upwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd",itau_w,dnwd)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dnwd0",itau_w,dnwd0)
+c
+      ENDIF !iflag_con.GE.3
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtdyn",itau_w,d_t_dyn)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqdyn",itau_w,d_q_dyn)
+c
+cIM: 101003 : K/30min ==> K/s
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqcon",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+
+     .                             d_t_eva(1:klon,1:klev))/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_tmp_fi3d, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlschr",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqlsc",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqvdf",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dteva",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqeva",itau_w,zx_tmp_fi3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ptconv",itau_w,zpt_conv)
+c
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"ratqs",itau_w,ratqs)
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtajs",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqajs",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/30min ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtthe",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dqthe",itau_w,zx_tmp_fi3d)
+c
+c
+cIM: 101003 : K/day ==> K/s
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY 
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtswr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtsw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlwr",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : K/day ==> K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtlw0",itau_w,zx_tmp_fi3d)
+c
+cIM: 101003 : deja en K/s      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dtec",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duvdf",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvvdf",itau_w,zx_tmp_fi3d)
+c
+      IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"duoro",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvoro",itau_w,zx_tmp_fi3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dulif",itau_w,zx_tmp_fi3d)
+c
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjmp1,zx_tmp_fi3d,zx_tmp_3d)
+      CALL histwrite_phy(nid_mth,"dvlif",itau_w,zx_tmp_fi3d)
+      ENDIF
+C
+#if defined(INCA_AER) && defined(CPP_COUPLE)
+      CALL histwrite_phy(nid_mth,"tau",itau_w,cldtau)
+      CALL histwrite_phy(nid_mth,"CCM1",itau_w,ccm(:,:,1))
+      CALL histwrite_phy(nid_mth,"CCM2",itau_w,ccm(:,:,2))
+      CALL histwrite_phy(nid_mth,"taupi",itau_w,cldtaupi)
+      CALL histwrite_phy(nid_mth,"cldemi",itau_w,cldemi)
+      CALL histwrite_phy(nid_mth,"SWTOAAS_ZERO",itau_w,topsw_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AER",itau_w,topsw_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_NAT",itau_w,topsw_inca(:,3))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AD",itau_w,topswad_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOAAS_AI",itau_w,topswai_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_ZERO",itau_w,topsw0_inca(:,1))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AER",itau_w,topsw0_inca(:,2))
+      CALL histwrite_phy(nid_mth,"SWTOACS_AD",itau_w,topswad0_inca(:))
+      CALL histwrite_phy(nid_mth,"SWTOACS_NAT",itau_w,topsw0_inca(:,3))
+#endif
+#ifndef INCA
+      IF (nqmax.GE.3) THEN
+      DO iq=3,nqmax
+cym         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq), zx_tmp_3d)
+         CALL histwrite_phy(nid_mth,tnom(iq),itau_w,qx(:,:,iq))
+      ENDDO
+      ENDIF
+#endif
+c
+      ENDIF !lev_histmth.GE.4
+c
+      ENDIF !(type_run.EQ."AMIP")
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_mth)
+c$OMP END MASTER
+      endif
+c
+      ENDIF !ok_mensuel
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histmthNMC.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histmthNMC.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histmthNMC.h	(revision 984)
@@ -0,0 +1,126 @@
+!
+! $Header$
+!
+      IF (ok_mensuel) THEN
+c
+       ndex3d = 0
+       itau_w = itau_phy + itap
+ccc
+c  Champs interpolles sur des niveaux de pression du NMC
+c
+c     PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+ccc
+      IF(type_run.EQ."CLIM".OR.type_run.EQ."ENSP") THEN
+ccc
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,2),
+cym     $      zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,2))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,2),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,2))
+ccc
+      ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+ccc
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,tsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"temp",itau_w,tsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,phisumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"phi",itau_w,phisumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,qsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"q",itau_w,qsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,rhsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"rh",itau_w,rhsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,usumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"u",itau_w,usumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"v",itau_w,vsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"w",itau_w,wsumSTD(:,:,3))
+c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,3).NE.1.E+20) THEN
+          zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,3))/ecrit_hf2mth
+         ELSE
+          zx_tmp_fiNC(i,k) = 1.E+20
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,zx_tmp_fiNC,zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"psbg",itau_w,zx_tmp_fiNC)
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,uvsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"uv",itau_w,uvsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vqsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vq",itau_w,vqsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vTsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vT",itau_w,vTsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1, wqsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"wq",itau_w,wqsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,vphisumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vphi",itau_w,vphisumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,wTsumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"wT",itau_w,wTsumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,u2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"uxu",itau_w,u2sumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,v2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"vxv",itau_w,v2sumSTD(:,:,3))
+c
+cym       CALL gr_fi_ecrit(nlevSTD, klon,iim,jjmp1,T2sumSTD(:,:,3),
+cym     $     zx_tmp_NC)
+       CALL histwrite_phy(nid_nmc,"TxT",itau_w,T2sumSTD(:,:,3))
+c
+      ENDIF !type_run
+c
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_nmc)
+c$OMP END MASTER
+      endif
+
+      ENDIF
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_histrac.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_histrac.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_histrac.h	(revision 984)
@@ -0,0 +1,106 @@
+!
+! $Header$
+!
+#ifndef INCA
+      ndex = 0
+      ndex2d = 0
+      ndex3d = 0
+c
+      itau_w = itau_phy + nstep
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+      CALL histwrite_phy(nid_tra,"phis",itau_w,pphis)
+C
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,airephy,zx_tmp_2d)      
+      CALL histwrite_phy(nid_tra,"aire",itau_w,airephy)
+
+      DO it=1,nqmax
+C champs 2D
+
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,tr_seri(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,tnom(it+2),itau_w,tr_seri(:,:,it))
+       if (lessivage) THEN
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"fl"//tnom(it+2),itau_w,
+     .                                   flestottr(:,:,it))
+      endif
+      
+c----Olivia
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_th(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_th_"//tnom(it+2),itau_w,
+     .                                           d_tr_th(:,:,it))
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cv(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_cv_"//tnom(it+2),itau_w,
+     .                                           d_tr_cv(:,:,it))
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,d_tr_cl(1,1,it),zx_tmp_3d)
+       CALL histwrite_phy(nid_tra,"d_tr_cl_"//tnom(it+2),itau_w,
+     .                                           d_tr_cl(:,:,it))
+c---fin Olivia      
+      
+      ENDDO
+
+
+C abder
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,yu1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"pyu1",itau_w,yu1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,yv1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"pyv1",itau_w,yv1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol1",itau_w,pftsol1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol2,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol2",itau_w,pftsol2)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol3,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol3",itau_w,pftsol3)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol4,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"ftsol4",itau_w,pftsol4)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf1,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf1",itau_w,ppsrf1)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf2,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf2",itau_w,ppsrf2)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf3,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf3",itau_w,ppsrf3)
+
+cym      CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf4,zx_tmp_2d)
+         CALL histwrite_phy(nid_tra,"psrf4",itau_w,ppsrf4)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pplay,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"pplay",itau_w,pplay)
+
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,t_seri,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"t",itau_w,t_seri)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfu,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"mfu",itau_w,pmfu)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfd,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"mfd",itau_w,pmfd)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_u,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"en_u",itau_w,pen_u)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_d,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"en_d",itau_w,pen_d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_d,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"de_d",itau_w,pde_d)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_u,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"de_u",itau_w,pde_u)
+cym      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,coefh,zx_tmp_3d)
+        CALL histwrite_phy(nid_tra,"coefh",itau_w,coefh)
+
+
+c abder
+
+      if (ok_sync) then
+c$OMP MASTER
+        call histsync(nid_tra)
+c$OMP END MASTER
+       endif
+
+#endif
+
+
+
Index: LMDZ4/tags/LF_20080728/libf/phytherm/write_paramLMDZ_phy.h
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/write_paramLMDZ_phy.h	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/write_paramLMDZ_phy.h	(revision 984)
@@ -0,0 +1,345 @@
+c
+      IF (is_sequential) THEN
+      
+      ndex2d = 0
+      itau_w = itau_phy + itap
+c
+c Variables type caractere : plusieurs valeurs possibles
+c
+      IF(ocean.EQ.'force ') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE IF(ocean.EQ.'slab  ') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=2.
+      ELSE IF(ocean.EQ.'couple') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=3.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ocean",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_slab_sicOBS) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_slab_sicOBS",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(type_run.EQ.'CLIM'.OR.type_run.EQ.'ENSP') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE IF(type_run.EQ.'AMIP'.OR.type_run.EQ.'CFMI') THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=2.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"type_run",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c Variables logiques (1=true, 2=false)
+c
+      IF(ok_veget) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_veget",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_journe) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_journe",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_mensuel) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_mensuel",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_instan) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_instan",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_ade) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_ade",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_aie) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_aie",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+
+c
+c Champs 2D:
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=bl95_b0
+      CALL histwrite(nid_ctesGCM,"bl95_b0",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=bl95_b1
+      CALL histwrite(nid_ctesGCM,"bl95_b1",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ip_ebil_phy
+      CALL histwrite(nid_ctesGCM,"ip_ebil_phy",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_ecc
+      CALL histwrite(nid_ctesGCM,"R_ecc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_peri
+      CALL histwrite(nid_ctesGCM,"R_peri",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=R_incl
+      CALL histwrite(nid_ctesGCM,"R_incl",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=solaire
+      CALL histwrite(nid_ctesGCM,"solaire",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=co2_ppm
+      CALL histwrite(nid_ctesGCM,"co2_ppm",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CH4_ppb
+      CALL histwrite(nid_ctesGCM,"CH4_ppb",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=N2O_ppb
+      CALL histwrite(nid_ctesGCM,"N2O_ppb",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CFC11_ppt
+      CALL histwrite(nid_ctesGCM,"CFC11_ppt",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=CFC12_ppt
+      CALL histwrite(nid_ctesGCM,"CFC12_ppt",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=epmax
+      CALL histwrite(nid_ctesGCM,"epmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_adj_ema) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_adj_ema",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_clw
+      CALL histwrite(nid_ctesGCM,"iflag_clw",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_lsc
+      CALL histwrite(nid_ctesGCM,"cld_lc_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_lc_con
+      CALL histwrite(nid_ctesGCM,"cld_lc_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_lsc
+      CALL histwrite(nid_ctesGCM,"cld_tau_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cld_tau_con
+      CALL histwrite(nid_ctesGCM,"cld_tau_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ffallv_lsc
+      CALL histwrite(nid_ctesGCM,"ffallv_lsc",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ffallv_con
+      CALL histwrite(nid_ctesGCM,"ffallv_con",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=coef_eva
+      CALL histwrite(nid_ctesGCM,"coef_eva",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(reevap_ice) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"reevap_ice",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_cldcon
+      CALL histwrite(nid_ctesGCM,"iflag_cldcon",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_pdf
+      CALL histwrite(nid_ctesGCM,"iflag_pdf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=fact_cldcon
+      CALL histwrite(nid_ctesGCM,"fact_cldcon",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=facttemps
+      CALL histwrite(nid_ctesGCM,"facttemps",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_newmicro) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_newmicro",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ratqsbas
+      CALL histwrite(nid_ctesGCM,"ratqsbas",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ratqshaut
+      CALL histwrite(nid_ctesGCM,"ratqshaut",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_froid
+      CALL histwrite(nid_ctesGCM,"rad_froid",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_chau1
+      CALL histwrite(nid_ctesGCM,"rad_chau1",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=rad_chau2
+      CALL histwrite(nid_ctesGCM,"rad_chau2",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=top_height
+      CALL histwrite(nid_ctesGCM,"top_height",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=overlap
+      CALL histwrite(nid_ctesGCM,"overlap",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cdmmax
+      CALL histwrite(nid_ctesGCM,"cdmmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=cdhmax
+      CALL histwrite(nid_ctesGCM,"cdhmax",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ksta
+      CALL histwrite(nid_ctesGCM,"ksta",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ksta_ter
+      CALL histwrite(nid_ctesGCM,"ksta_ter",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_kzmin) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_kzmin",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=iflag_pbl
+      CALL histwrite(nid_ctesGCM,"iflag_pbl",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histhf
+      CALL histwrite(nid_ctesGCM,"lev_histhf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histday
+      CALL histwrite(nid_ctesGCM,"lev_histday",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lev_histmth
+      CALL histwrite(nid_ctesGCM,"lev_histmth",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      IF(ok_isccp) THEN
+       zx_tmp_2d(1:iim,1:jjmp1)=1.
+      ELSE
+       zx_tmp_2d(1:iim,1:jjmp1)=0.
+      ENDIF
+      CALL histwrite(nid_ctesGCM,"ok_isccp",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lonmin_ins
+      CALL histwrite(nid_ctesGCM,"lonmin_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=lonmax_ins
+      CALL histwrite(nid_ctesGCM,"lonmax_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=latmin_ins
+      CALL histwrite(nid_ctesGCM,"latmin_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=latmax_ins
+      CALL histwrite(nid_ctesGCM,"latmax_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ins
+      CALL histwrite(nid_ctesGCM,"ecrit_ins",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_hf
+      CALL histwrite(nid_ctesGCM,"ecrit_hf",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_day
+      CALL histwrite(nid_ctesGCM,"ecrit_day",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_mth
+      CALL histwrite(nid_ctesGCM,"ecrit_mth",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_tra
+      CALL histwrite(nid_ctesGCM,"ecrit_tra",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_reg
+      CALL histwrite(nid_ctesGCM,"ecrit_reg",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=freq_ISCCP
+      CALL histwrite(nid_ctesGCM,"freq_ISCCP",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_2d(1:iim,1:jjmp1)=ecrit_ISCCP
+      CALL histwrite(nid_ctesGCM,"ecrit_ISCCP",itau_w,
+     .               zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c=================================================================
+c=================================================================
+c=================================================================
+c
+      if (ok_sync) then
+        call histsync(nid_ctesGCM)
+      endif
+c
+      ENDIF ! mono_cpu
Index: LMDZ4/tags/LF_20080728/libf/phytherm/yamada.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/yamada.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/yamada.F	(revision 984)
@@ -0,0 +1,173 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer l_mix,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      save first
+      data first/.true./
+
+
+      integer ig,k
+
+      real ri,zrif,zalpha,zsm
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real l(klon,klev+1),l0(klon)
+
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/
+
+      real frif,falpha,fsm
+
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+         print*,ri,rif,zalpha,zsm
+      enddo
+      first=.false.
+      endif
+
+c  Correction d'un bug sauvage a verifier.
+c      do k=2,nlev
+      do k=2,nlay
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1))
+     s            /(teta(ig,k-1)+teta(ig,k))  /dz(ig,k)
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+c iterration pour determiner la longueur de melange
+
+                                                          do ig=1,ngrid
+      l0(ig)=100.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+c(abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+                                                          enddo
+      enddo
+
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/yamada4.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/yamada4.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/yamada4.F	(revision 984)
@@ -0,0 +1,488 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar
+     s   ,iflag_pbl)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c  iflag_pbl doit valoir entre 6 et 9
+c      l=6, on prend  systematiquement une longueur d'equilibre
+c    iflag_pbl=6 : MY 2.0
+c    iflag_pbl=7 : MY 2.0.Fournier
+c    iflag_pbl=8 : MY 2.5
+c    iflag_pbl=9 : un test ?
+
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),qpre
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+
+      REAL km(klon,klev+1)
+      REAL kmpre(klon,klev+1),tmp2
+      REAL mpre(klon,klev+1)
+      REAL kn(klon,klev+1)
+      REAL kq(klon,klev+1)
+      real ff(klon,klev+1),delta(klon,klev+1)
+      real aa(klon,klev+1),aa0,aa1
+      integer iflag_pbl,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      integer ipas
+      save first,ipas
+      data first,ipas/.true.,0/
+c$OMP THREADPRIVATE( first,ipas)
+
+      integer ig,k
+
+
+      real ri,zrif,zalpha,zsm,zsn
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real dtetadz(klon,klev+1)
+      real m2cstat,mcstat,kmcstat
+      real l(klon,klev+1)
+      real,allocatable,save :: l0(:)
+c$OMP THREADPRIVATE(l0)      
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
+c$OMP THREADPRIVATE(ric,rifc,b1,kap)
+      real frif,falpha,fsm
+      real fl,zzz,zl0,zq2,zn2
+
+cym      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
+cym     s  ,lyam(klon,klev),knyam(klon,klev)
+cym     s  ,w2yam(klon,klev),t2yam(klon,klev)
+      real,allocatable,save,dimension(:,:) :: rino,smyam,styam,lyam,
+     s                                        knyam,w2yam,t2yam
+cym      common/pbldiag/rino,smyam,styam,lyam,knyam,w2yam,t2yam
+c$OMP THREADPRIVATE(rino,smyam,styam,lyam,knyam,w2yam,t2yam)
+      logical,save :: firstcall=.true.
+c$OMP THREADPRIVATE(firstcall)       
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+      fl(zzz,zl0,zq2,zn2)=
+     s     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
+
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (firstcall) then
+        allocate(rino(klon,klev+1),smyam(klon,klev),styam(klon,klev))
+        allocate(lyam(klon,klev),knyam(klon,klev))
+        allocate(w2yam(klon,klev),t2yam(klon,klev))
+	allocate(l0(klon))
+	firstcall=.false.
+      endif
+
+
+      if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.9)) then
+           stop'probleme de coherence dans appel a MY'
+      endif
+
+      ipas=ipas+1
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+c     print*,ri,rif,zalpha,zsm
+      enddo
+      endif
+
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO ig=1,ngrid
+            zlev(ig,nlev)=zlay(ig,nlay)
+     &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
+                                                      ENDDO
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO k=1,nlay
+                                                      DO ig=1,ngrid
+        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+                                                      ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
+                                                      ENDDO
+      DO k=2,nlay
+                                                      DO ig=1,ngrid
+        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+                                                     ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+                                                     ENDDO
+c
+c.......................................................................
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
+         n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
+c        n2(ig,k)=0.
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+c     print*,'RIF L=',k,rif(ig,k),ri*alpha(ig,k)
+
+
+                                                          enddo
+      enddo
+
+
+c====================================================================
+c   Au premier appel, on determine l et q2 de facon iterative.
+c iterration pour determiner la longueur de melange
+
+
+      if (first.or.iflag_pbl.eq.6) then
+                                                          do ig=1,ngrid
+      l0(ig)=10.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+c        l0(ig)=30.
+                                                          enddo
+c      print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+c     print*,'Fin de l initialisation de q2 et l0'
+
+      endif ! first
+
+c====================================================================
+c  Calcul de la longueur de melange.
+c====================================================================
+
+c   Mise a jour de l0
+                                                          do ig=1,ngrid
+      sq(ig)=1.e-10
+      sqz(ig)=1.e-10
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        zq=sqrt(q2(ig,k))
+        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+      enddo
+                                                          do ig=1,ngrid
+      l0(ig)=0.2*sqz(ig)/sq(ig)
+c        l0(ig)=30.
+                                                          enddo
+c      print*,'ITER=',iter,'  L0=',l0
+c   calcul de l(z)
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+         if(first) then
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         endif
+                                                          enddo
+      enddo
+
+c====================================================================
+c   Yamada 2.0
+c====================================================================
+      if (iflag_pbl.eq.6) then
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+                                                          enddo
+      enddo
+
+
+      else if (iflag_pbl.eq.7) then
+c====================================================================
+c   Yamada 2.Fournier
+c====================================================================
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         mpre(ig,k)=sqrt(m2(ig,k))
+c        print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+                                                          enddo
+      enddo
+
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12)
+        mcstat=sqrt(m2cstat)
+
+c        print*,'M2 L=',k,mpre(ig,k),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (k.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)
+     &              *cd(ig)
+     &              *( sqrt(u(ig,3)**2+v(ig,3)**2)
+     &                -mcstat/unsdzdec(ig,k)
+     &                -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2)
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)*kmpre(ig,k-1)
+     &                          *mpre(ig,k-1) )
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ENDIF
+c       print*,'T2 L=',k,tmp2
+        tmp2=kmcstat
+     &      /( sm(ig,k)/q2(ig,k) )
+     &      /l(ig,k)
+        q2(ig,k)=max(tmp2,1.e-12)**(2./3.)
+c       print*,'Q2 L=',k,q2(ig,k)
+c
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl.ge.8) then
+c====================================================================
+c   Yamada 2.5 a la Didi
+c====================================================================
+
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         if (delta(ig,k).lt.1.e-20) then
+c     print*,'ATTENTION   L=',k,'   Delta=',delta(ig,k)
+            delta(ig,k)=1.e-20
+         endif
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         aa0=
+     s   (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+         aa1=
+     s   (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+c abder      print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20)
+         aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k))
+c     print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+         qpre=sqrt(q2(ig,k))
+         if (iflag_pbl.eq.8 ) then
+            if (aa(ig,k).gt.0.) then
+               q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+         else ! iflag_pbl=9
+            if (aa(ig,k)*qpre.gt.0.9) then
+               q2(ig,k)=(qpre*10.)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+         endif
+         q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4)
+c     print*,'Q2 L=',k,q2(ig,k),qpre*qpre
+                                                          enddo
+      enddo
+
+      endif ! Fin du cas 8
+
+c     print*,'OK8'
+
+c====================================================================
+c   Calcul des coefficients de m�ange
+c====================================================================
+      do k=2,klev
+c     print*,'k=',k
+                                                          do ig=1,ngrid
+cabde      print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k)
+         zq=sqrt(q2(ig,k))
+         km(ig,k)=l(ig,k)*zq*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+         kq(ig,k)=l(ig,k)*zq*0.2
+c     print*,'KML=',km(ig,k),kn(ig,k)
+                                                          enddo
+      enddo
+
+c     if (iflag_pbl.ge.7..and.0.eq.1) then
+c        q2(:,1)=q2(:,2)
+c        call vdif_q2(dt,g,rconst,plev,temp,kq,q2)
+c     endif
+
+c   Traitement des cas noctrunes avec l'introduction d'une longueur
+c   minilale.
+
+c====================================================================
+c   Traitement particulier pour les cas tres stables.
+c   D'apres Holtslag Boville.
+
+      print*,'YAMADA4 0'
+
+                                                          do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+                                                          enddo
+
+!      print*,'pblhmin ',pblhmin
+CTest a remettre 21 11 02
+c test abd 13 05 02      if(0.eq.1) then
+      if(1.eq.1) then
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+c   la longueur de melange est suposee etre l= kap z
+c   K=l q Sm d'ou q2=(K/l Sm)**2
+               q2(ig,k)=(qmin/sm(ig,k))**2
+            endif
+         enddo
+      enddo
+      endif
+
+      print*,'YAMADA4 1'
+c   Diagnostique pour stokage
+
+      if(1.eq.0)then
+      rino=rif
+      smyam(1:ngrid,1)=0.
+      styam(1:ngrid,1)=0.
+      lyam(1:ngrid,1)=0.
+      knyam(1:ngrid,1)=0.
+      w2yam(1:ngrid,1)=0.
+      t2yam(1:ngrid,1)=0.
+
+      smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)
+      styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev)
+      lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev)
+      knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev)
+
+c   Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+
+      w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24
+     s    +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev)
+     s    *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev))
+
+      t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev)
+     s    *dtetadz(1:ngrid,2:klev)**2
+     s    /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev)
+      endif
+
+c     print*,'OKFIN'
+      first=.false.
+      return
+      end
Index: LMDZ4/tags/LF_20080728/libf/phytherm/zilch.F
===================================================================
--- LMDZ4/tags/LF_20080728/libf/phytherm/zilch.F	(revision 984)
+++ LMDZ4/tags/LF_20080728/libf/phytherm/zilch.F	(revision 984)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      subroutine zilch(x,m)
+c
+c Zero the real array x dimensioned m.
+c
+      implicit none
+c
+      integer m,i
+      real x(m)
+      do 1 i=1,m
+      x(i)= 0.0  
+    1 continue
+      return
+      end
Index: LMDZ4/tags/LF_20080728/machine/arch-ES_MOON.fcm
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-ES_MOON.fcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-ES_MOON.fcm	(revision 984)
@@ -0,0 +1,10 @@
+%COMPILER            esmpif90
+%LINK                esmpif90
+%AR                  esar
+%MAKE                gmake
+%FFLAGS              -C vopt  -Wf,-pvctl res=whole,-A dbl4,-ptr byte -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -ftrace -P stack
+%FPP                 c89 -E
+%FPP_FLAGS           -P
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM 
+%LD_FLAGS            -lblas -ftrace
+
Index: LMDZ4/tags/LF_20080728/machine/arch-ES_MOON.path
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-ES_MOON.path	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-ES_MOON.path	(revision 984)
@@ -0,0 +1,11 @@
+set NETCDF_LIBDIR=/S/home010/c0010/ES/lib
+set NETCDF_INCDIR=/S/home010/c0010/ES/include
+set IOIPSL_INCDIR=$LMDGCM/../../lib
+set IOIPSL_LIBDIR=$LMDGCM/../../lib
+set ORCH_INCDIR=$LMDGCM/../../lib
+set ORCH_LIBDIR=$LMDGCM/../../lib
+set OASIS_INCDIR=$LMDGCM/../../prism/ES/build/lib/psmile.$couple
+set OASIS_LIBDIR=$LMDGCM/../../prism/ES/lib
+set INCA_LIBDIR=$LMDGCM/../INCA3/config/lib
+set INCA_INCDIR=$LMDGCM/../INCA3/config/lib
+set LIBPREFIX=sx
Index: LMDZ4/tags/LF_20080728/machine/arch-IA64_PLATINE.fcm
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-IA64_PLATINE.fcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-IA64_PLATINE.fcm	(revision 984)
@@ -0,0 +1,8 @@
+%COMPILER            mpif90
+%LINK                mpif90
+%AR                  ar
+%MAKE                gmake
+%FFLAGS              -O3 -i4 -r8 -automatic -align all
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM 
+%LD_FLAGS            -i4 -r8 -automatic -L/applications/intel/ict/3.0/cmkl/9.0/lib/64 -lmkl_ipf -lguide
Index: LMDZ4/tags/LF_20080728/machine/arch-IA64_PLATINE.path
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-IA64_PLATINE.path	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-IA64_PLATINE.path	(revision 984)
@@ -0,0 +1,11 @@
+set NETCDF_LIBDIR='/usr/lib -lnetcdff'
+set NETCDF_INCDIR=/usr/include
+set IOIPSL_INCDIR=$LMDGCM/../../lib
+set IOIPSL_LIBDIR=$LMDGCM/../../lib
+set ORCH_INCDIR=$LMDGCM/../../lib
+set ORCH_LIBDIR=$LMDGCM/../../lib
+set OASIS_INCDIR=$LMDGCM/../../prism/IA64/build/lib/psmile.$couple
+set OASIS_LIBDIR=$LMDGCM/../../prism/IA64/lib
+set INCA_LIBDIR=$LMDGCM/../INCA3/config/lib
+set INCA_INCDIR=$LMDGCM/../INCA3/config/lib
+
Index: LMDZ4/tags/LF_20080728/machine/arch-SX8_BRODIE.fcm
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-SX8_BRODIE.fcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-SX8_BRODIE.fcm	(revision 984)
@@ -0,0 +1,9 @@
+%COMPILER            sxmpif90
+%LINK                sxmpif90
+%AR                  sxar
+%MAKE                make
+%FFLAGS              -C vopt  -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume"
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM 
+%LD_FLAGS            -lblas
+
Index: LMDZ4/tags/LF_20080728/machine/arch-SX8_BRODIE.path
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-SX8_BRODIE.path	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-SX8_BRODIE.path	(revision 984)
@@ -0,0 +1,11 @@
+set NETCDF_LIBDIR=/SXlocal/pub/netCDF/netCDF-3.6.1/lib
+set NETCDF_INCDIR=/SXlocal/pub/netCDF/netCDF-3.6.1/include
+set IOIPSL_INCDIR=$LMDGCM/../../lib
+set IOIPSL_LIBDIR=$LMDGCM/../../lib
+set ORCH_INCDIR=$LMDGCM/../../lib
+set ORCH_LIBDIR=$LMDGCM/../../lib
+set OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple
+set OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib
+set INCA_LIBDIR=$LMDGCM/../INCA3/config/lib
+set INCA_INCDIR=$LMDGCM/../INCA3/config/lib
+
Index: LMDZ4/tags/LF_20080728/machine/arch-SX8_MERCURE.fcm
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-SX8_MERCURE.fcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-SX8_MERCURE.fcm	(revision 984)
@@ -0,0 +1,9 @@
+%COMPILER            sxmpif90
+%LINK                sxmpif90
+%AR                  sxar
+%MAKE                make
+%FFLAGS              -C vopt  -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume"
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             NC_DOUBLE BLAS SGEMV=DGEMV SGEMM=DGEMM 
+%LD_FLAGS            -size_t64 -lblas
+
Index: LMDZ4/tags/LF_20080728/machine/arch-SX8_MERCURE.path
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-SX8_MERCURE.path	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-SX8_MERCURE.path	(revision 984)
@@ -0,0 +1,10 @@
+set NETCDF_LIBDIR=/usr/local/SX8/soft/netcdf/lib
+set NETCDF_INCDIR=/usr/local/SX8/soft/netcdf/include
+set IOIPSL_INCDIR=$LMDGCM/../../lib
+set IOIPSL_LIBDIR=$LMDGCM/../../lib
+set ORCH_INCDIR=$LMDGCM/../../lib
+set ORCH_LIBDIR=$LMDGCM/../../lib
+set OASIS_INCDIR=$LMDGCM/../../prism/SX/build/lib/psmile.$couple
+set OASIS_LIBDIR=$LMDGCM/../../prism/SX/lib
+set INCA_LIBDIR=$LMDGCM/../INCA3/config/lib
+set INCA_INCDIR=$LMDGCM/../INCA3/config/lib
Index: LMDZ4/tags/LF_20080728/machine/arch-linux-32bit.fcm
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-linux-32bit.fcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-linux-32bit.fcm	(revision 984)
@@ -0,0 +1,8 @@
+%COMPILER            pgf90
+%LINK                pgf90
+%AR                  ar
+%MAKE                make
+%FFLAGS              -fast
+%FPP_FLAGS           -P -traditional
+%FPP_DEF             
+%LD_FLAGS            -Wl,-Bstatic -L/usr/lib/gcc-lib/i386-linux/2.95.2/
Index: LMDZ4/tags/LF_20080728/machine/arch-linux-32bit.path
===================================================================
--- LMDZ4/tags/LF_20080728/machine/arch-linux-32bit.path	(revision 984)
+++ LMDZ4/tags/LF_20080728/machine/arch-linux-32bit.path	(revision 984)
@@ -0,0 +1,6 @@
+set NETCDF_LIBDIR=/distrib/local/netcdf/pgi_32bits/lib/
+set NETCDF_INCDIR=/distrib/local/netcdf/pgi_32bits/include
+set IOIPSL_INCDIR=/u/fairhead/modipsl_ioipsl_3/lib
+set IOIPSL_LIBDIR=/u/fairhead/modipsl_ioipsl_3/lib
+set ORCH_INCDIR=/u/fairhead/modipsl_ioipsl_3/lib
+set ORCH_LIBDIR=/u/fairhead/modipsl_ioipsl_3/lib
Index: LMDZ4/tags/LF_20080728/makegcm
===================================================================
--- LMDZ4/tags/LF_20080728/makegcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/makegcm	(revision 984)
@@ -0,0 +1,1089 @@
+#!/bin/csh
+#
+# $Header$
+#
+#set verbose echo
+########################################################################
+# options par defaut pour la commande make
+########################################################################
+set dim="96x71x19"
+set physique=lmd
+set phys="PHYS=$physique"
+set include='-I$(LIBF)/grid -I$(LIBF)/bibio -I$(LIBF)/filtrez -I. '
+set ntrac = 4
+set filtre=filtrez
+set grille=reg
+set couple=false
+set veget=false
+set chimie=false
+set psmile=true
+set parallel=false
+set vampir=false
+set OPT_STACK='-Wf,-init stack=nan'
+set OPT_STACK=' '
+set OPTIMI='-C debug -eC '
+set OPTIMI=' -ftrace '
+set OPT_LINUX='-O3'
+set io=ioipsl
+
+set FC_LINUX=g95
+#set FC_LINUX=pgf90
+
+########################################################################
+# path a changer contenant les sources et les objets du modele
+########################################################################
+
+###### VERSION LMDZ.4
+#set LMDGCM=/workdir/p86cozic/INCA_dev/LMDZ4
+#setenv LIBOGCM $LMDGCM/libo
+set INCALIB=../INCA3/config/lib
+#set LMDGCM="`pwd`"
+#setenv LIBOGCM $LMDGCM/libo
+#set LMDGCM=/d4/fairhead/V4/
+#setenv LIBOGCM $LMDGCM/libo
+#
+#
+#setenv IOIPSLDIR /u/fairhead/modipsl_ioipsl_3/lib_i4r4_32bits
+#setenv MODIPSLDIR /u/fairhead/modipsl_ioipsl_3/lib_i4r4_32bits
+#setenv NCDFINC /distrib/local/netcdf/pgi_32bits/include
+#setenv NCDFLIB /distrib/local/netcdf/pgi_32bits/lib/
+#setenv IOIPSLDIR /d4/fairhead/Install_LMDZ4_FH/LMDZ4preV4/modipsl/lib/
+#setenv MODIPSLDIR /d4/fairhead/Install_LMDZ4_FH/LMDZ4preV4/modipsl/lib/
+#setenv NCDFINC /d4/fairhead/Install_LMDZ4_FH/LMDZ4preV4/netcdf-3.6.1/include
+#setenv NCDFLIB /d4/fairhead/Install_LMDZ4_FH/LMDZ4preV4/netcdf-3.6.1/lib
+
+
+
+setenv localdir "`pwd`"
+set MODIPSL=0
+echo $localdir | grep modipsl >& /dev/null
+if ( ! $status ) then
+  set MODIPSL=1
+  setenv LMDGCM $localdir
+  cd ../..
+  setenv LIBOGCM "`pwd`/lib"
+  setenv IOIPSLDIR $LIBOGCM
+  setenv MODIPSLDIR $LIBOGCM
+  cd $localdir
+  if ( `hostname` == rhodes ) then
+    set NCDFINC=`grep sxnec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+    set NCDFLIB=`grep sxnec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+  else
+    if ( `hostname` == nymphea0 ) then
+      set NCDFINC=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+      set NCDFLIB=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+    else if ( `hostname` == mercure ) then
+      set NCDFINC=`grep sx6nec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+      set NCDFLIB=`grep sx6nec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+    else  if ( `hostname` == brodie ) then
+      set NCDFINC=`grep sx8brodie ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+      set NCDFLIB=`grep sx8brodie ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+    else
+      echo 'Probleme de definition des variables NCDFINC et NCDFLIB'
+    endif 
+  endif 
+else
+  if ( ! $?LMDGCM ) then
+    echo You must initialize the variable LMDGCM in your environnement
+    echo for instance: "setenv LMDGCM /usr/myself/supergcm" in .cshrc
+    exit
+  endif
+  if ( ! $?LIBOGCM ) then
+    set LIBOGCM=$LMDGCM/libo
+  endif
+  if ( ! $?IOIPSLDIR ) then
+    echo You must initialize the variable IOIPSLDIR in your environnement
+    echo for instance: "setenv IOIPSLDIR /usr/myself/ioipsl" in .cshrc
+    exit
+  else
+      setenv MODIPSLDIR $IOIPSLDIR
+  endif
+  if ( ! $?NCDFLIB ) then
+    echo You must initialize the variable NCDFLIB in your environnement
+    echo for instance: "setenv NCDFLIB /usr/myself/netcdf" in .cshrc
+    exit
+  endif
+  if ( ! $?NCDFINC ) then
+    echo You must initialize the variable NCDFINC in your environnement
+    echo for instance: "setenv NCDFINC /usr/myself/netcdf" in .cshrc
+    exit
+  endif
+endif
+set model=$LMDGCM
+set libo=$LIBOGCM
+
+########################################################################
+#  Les differentes platformes reconnues
+########################################################################
+
+set HP=0
+set IBM=0
+set SUN=0
+set VPP=0
+set CRAY=0
+set DEC=0
+set LINUX=0
+set NEC=0
+set XNEC=0
+set X6NEC=0
+set X8BRODIE=0
+if ( `uname` == HP-UX ) then
+   set machine=HP
+   set HP=1
+else if (`uname` == UNIX_System_V ) then
+   set machine=VPP
+   set VPP=1
+else if (`uname` == SunOS ) then
+   set machine=SUN
+   set SUN=1
+else if ( `uname` == AIX ) then
+   set machine=IBM
+   set IBM=1
+else if ( `uname` == OSF1 ) then
+   set machine=ALPHA
+   set DEC=1
+else if ( `uname` == Linux && `hostname` != mercure  && `hostname` != brodie ) then
+   set machine=LINUX
+   set LINUX=1
+else if ( `hostname` == atlas || `hostname` == axis  || `hostname` == etoile ) then
+   set machine=CRAY
+   set CRAY=1
+else if ( `uname` == SUPER-UX ) then
+   set machine=NEC
+   set NEC=1
+else if ( `hostname` == rhodes) then
+   set machine=XNEC
+   set XNEC=1
+else if ( `hostname` == mercure) then
+   set machine=X6NEC
+   set X6NEC=1
+else if ( `hostname` == brodie) then
+   set machine=X8BRODIE
+   set X8BRODIE=1
+else
+   echo Vous travaillez sur une machine non prevue par le reglement
+   exit
+endif
+
+if ( ! -d $libo )  then
+   mkdir $libo
+endif
+
+
+if $VPP then
+set netcdf=netcdf_v
+else 
+set netcdf=netcdf
+endif
+########################################################################
+#  Quelques initialisations de variables du shell.
+########################################################################
+
+set dyn=
+set opt_link=""
+set adjnt=""
+set opt_dep=""
+set libchimie=""
+
+set optim=""
+set optimbis=""
+set optim90=""
+set oplink=""
+
+########################################################################
+#  Optimisations par defaut suivant les machines
+########################################################################
+
+echo "Optimisations par defaut suivant les machines"
+set libf=$model/libf
+#setenv localdir "LOCAL_DIR=`pwd`"
+#setenv localdir "`pwd`"
+cd $model
+#############
+if $CRAY then
+#############
+#   set optim="-Wf'-ei' -dp -Wf'-a static'"
+   set optimbis=" -DCRAY "
+   set optim90="-Wp'-P' -DCRAY -p$IOIPSLDIR "'-p$(LIBO) -eiv '
+   set optim="$optim90"
+   set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -lioipsl  -L$NCDFLIB -lnetcdf "
+   set mod_loc_dir=" "
+   set mod_suffix=" "
+#################
+else if $SUN then
+#################
+   set optim=" -fast "
+   set optimbis=" "
+   set optim90=" -fast -fixed "
+   set optimtru90=" -fast -free "
+   set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -lioipsl -L$NCDFLIB -lnetcdf "
+   set mod_loc_dir=$localdir
+   set mod_suffix=mod
+#################
+else if $HP then
+#################
+   set optim=" +U77 -O +E1 "
+   set optimbis=" "
+#################
+else if $IBM then
+#################
+   set optim=" -O3 -qtune=pwr2 -qarch=pwr2"
+   set optimbis=" "
+#################
+else if $VPP then
+#################
+#   set optim="-Dasuxm  -On, -g -Ad -Potilax -Eciplume -Si"
+#   set optimbis="  -Wv,-m3 -Wp,-DVPP -Z $LMDGCM/listage"
+   set optimbis=" -Wp,-DNC_DOUBLE -Ad -Z $LMDGCM/listage -X9"
+   set optim90="$optim $optimbis -X9 -w"
+   set mod_loc_dir=$MODIPSLDIR
+   set mod_suffix=mod
+#################
+else if $DEC then
+#################
+   set optim=" "
+   set optimbis=" "
+#################
+else if $LINUX then
+#################
+   if ( $FC_LINUX == "pgf90" ) then
+     set optim="-fast "
+     set optim90=" -fast "
+     set optimtru90=" -fast -c -Mfree "
+#     set optim=" "
+#     set optim90="  "
+#     set optimtru90=" -c -Mfree "
+   else if ( $FC_LINUX == 'g95' ) then 
+     set optim=" $OPT_LINUX "
+     set optim90=" $OPT_LINUX "
+     set optimtru90=" $OPT_LINUX "
+   else
+     echo 'compilateur linux non reconnu'
+     exit
+   endif
+   set mod_loc_dir=$MODIPSLDIR
+   set mod_suffix=mod
+#################
+else if $NEC then
+#################
+   set optim90=' -clear -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "'
+   set optimtru90=' -clear -f4 -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "'
+   set optim="$optim90"
+   set optimbis=" "
+   set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR -lioipsl  $NCDFLIB -lnetcdf_i8r8_v "
+   set mod_loc_dir="."
+   set mod_suffix="mod"
+#################
+else if $XNEC then
+#################
+   set optdbl='-dw -Wf\"-A dbl4\"'
+   set optim90=' -clear -float0 -f3 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "'
+   set optimtru90=' -clear -f4 -float0 -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"'
+   set optim="$optim90"
+   set optimbis=" "
+   set mod_suffix="mod"
+   set mod_loc_dir="./"
+#################
+else if $X6NEC then
+#################
+   set optdbl='-dw -Wf\"-A dbl4\"'  
+   set optim90=' -clear -float0 -size_t64 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "'
+   set optimtru90=' -clear -f4 -float0 -size_t64 -P stack -Wf "-ptr byte -init stack=nan -init heap=nan" -Ep -DNC_DOUBLE -dw -Wf\"-A dbl4\" -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"'
+   set optim="$optim90"
+   set optimbis=" "
+   set mod_suffix="mod"
+   set mod_loc_dir="./"
+#################
+else if $X8BRODIE then
+##################
+   set optdbl='-dw -Wf\"-A dbl4\"'  
+#   set optim90='-P stack -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -I/SX/usr/include'
+   set optim90='-C vopt -Wf,-pvctl res=whole,-A dbl4,-init stack=nan,-init heap=nan,-ptr byte -EP -DNC_DOUBLE -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 noassume" -I/SX/usr/include'
+#   set optim90='-C vsafe -P stack -Wf,-pvctl res=whole,-A dbl4,-ptr byte -EP -R5 -float0 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -I/SX/usr/include'
+   set optimtru90="$optim90"
+   set optim90="$optim90"
+   set optim="$optim90"
+   set optimbis=" "
+   set mod_suffix="mod"
+   set mod_loc_dir="./"
+else
+   set optim=""
+   set optimbis=" "
+endif
+
+set nomlib=$machine
+
+########################################################################
+# lecture des options de mymake
+########################################################################
+
+top:
+if ($#argv > 0) then
+    switch ($1:q)
+
+    case -h:
+
+########################################################################
+# Manuel en ligne
+########################################################################
+more <<eod
+
+
+makegcm [Options] prog
+
+
+
+
+Par default, la commande makegcm:
+---------------------------------
+
+1. compile une serie de sous programmes se trouvant dans des sous-repertoires
+de $LMDGCM/libf.
+Les sous programmes sont ensuite stokes sur dans des librairies FORTRAN
+sur $LIBOGCM.
+
+2. Ensuite, makegcm compile le programme prog.f se trouvant par default sur
+$LMDGCM/libf/dyn3d et effectue le lien avec l ensemble des librairies.
+
+La variable '$LMDGCM' doit etre initialisee dans votre .cshrc ou en dur
+dans la comande makegcm.
+
+La commande makegcm est faite pour permettre de gerer en parallele des
+versions differentes du modele, compilees avec des options de compilation
+et des dimensions differentes sans avoir a chaque fois a recompiler tout
+le modele.
+
+Les librairies FORTRAN sont stoquees sur le directory $LIBOGCM.
+
+
+OPTIONS:
+--------
+
+Les options suivantes peuvent etre definies soit par defaut en editant le
+"script" makegcm, soit en interactif:
+
+-d imxjmxlm  ou im, jm, et lm sont resp. le nombre de longitudes, latitudes
+             et couches verticales. 
+
+-t ntrac   selectionne le nombre de traceur advectes par la dynamique.
+           Dans les versions courantes du modele terrestre on a par exemple
+           ntrac=2 pour l'eau vapeur et liquide
+
+             L'effet des options -d et -t est d'ecraser le fichier 
+             $LMDGCM/libf/grid/dimensions.h
+             qui contient sous forme de 4 PARAMETER FORTRAN les 3 dimensions
+             de la grille horizontale im, jm, lm plus le nombre de traceurs
+             advectes passivement par la dynamique ntrac, par un nouveu fichier
+             $LMDGCM/libf/grid/dimension/dimensions.im.jm.lm.tntrac
+             Si ce fichier n'existe pas encore, il est cree par le script
+             $LMDGCM/libf/grid/dimension/makdim
+
+-p PHYS    pour selectionner le jeu de parametrisations physiques avec
+           lequel on veut compiler le modele.
+           Le modele sera alors compile en prenant les sources des
+           parametrisations physiques dans le repertoire:
+            $LMDGCM/libf/phyPHYS
+
+-c false|true
+           pour selectionner le mode force (par defaut) ou couple
+
+-io ioipsl|noioipsl
+           pour selectionner le logiciel IO : IOIPSL par defaut
+
+-psmile false|true
+           pour selectionner le mode psmile ou non (par defaut)
+
+-parallel  false|true
+           pour selectionner le mode parallele ou non (false par defaut)
+
+-v true|false
+           pour selectionner la vegetation (par defaut) ou non
+
+-chimie CH4|CH4_AER|NMHC|NMHC_AER|AER|GES|false
+	   pour selectionner ou non la chimie (par defaut sans)
+
+-g grille  selectionne le type de grille qu'on veut utiliser.
+           L'effet de cette option est d'ecraser le fichier
+           $LMDGCM/libf/grid/fxyprim.h
+           avec le fichier
+           $LMDGCM/libf/grid/fxy_grille.h
+           grille peut prendre les valeurs:
+           1. reg pour la grille reguliere
+           2. sin pour avoir des points equidistants en sinus de la latitude
+           3. new pour pouvoir zoomer sur une partie du globe
+
+-O "optimisation fortran" ou les optimisations fortran sont les options de la
+            commande f77
+
+-include path
+           Dans le cas ou on a dans des sous programmes des fichiers 
+           #include (cpp) qui se trouve sur des repertoires non references
+           par defaut
+
+-adjnt     Pour compiler la l'adjoint du code dynamique
+
+-filtre  filtre
+           Pour choisir le filtre en longitude dans les regions polaires.
+           "filtre" correspond au nom d'un repertoire se trouvant sur
+           $LMDGCM/libf. Le filtre standard du modele est "filtrez" qui peut
+           etre utilise aussi bien pour une grille reguliere que pour une 
+           grille zoomee en longitude.
+
+-link "-Ldir1 -lfile1 -Ldir2 -lfile2 ..."
+          Pour rajouter un lien avec les librairies FORTRAN
+          libfile1.a, libfile2.a ... se trouvant respectivement sur les
+          repertoires dir1, dir2 ...
+          Si dirn est un repertoire dont le chemin est automatique (comme
+          par exemple /usr/lib ...) il n'est pas besoin de specifier -Ldirn.
+
+Auteur: Frederic Hourdin  (hourdin@lmd.jussieu.fr)
+eod
+exit
+
+########################################################################
+# Lecture des differentes options
+########################################################################
+
+    case -d:
+        set dim=$2 ; shift ; shift ; goto top
+                        
+    case -O:
+        set optim="$2" ; shift ; shift ; goto top
+
+     case -p
+        set physique="$2" ; set phys="PHYS=$physique" ; shift ; shift ; goto top
+
+     case -g
+        set grille="$2" ; shift ; shift ; goto top
+
+     case -c
+        set couple="$2" ; shift ; shift ; goto top
+
+     case -io
+        set io="$2" ; shift ; shift ; goto top
+
+     case -v
+        set veget="$2" ; shift ; shift ; goto top
+
+     case -chimie
+	set chimie="$2" ; shift ; shift ; goto top
+
+     case -parallel
+        set parallel="$2" ; shift ; shift ; goto top
+  
+     case -t
+        set ntrac=$2 ; shift ; shift ; goto top
+
+     case -include
+        set include="$include -I$2" ; shift ; shift ; goto top
+
+     case -adjnt
+        set opt_dep="$opt_dep adjnt" ; set adjnt="-ladjnt -ldyn3d "
+        set optim="$optim -Dadj" ; shift ; goto top
+
+     case -filtre
+        set filtre=$2 ; shift ; shift ; goto top
+
+     case -link
+        set opt_link="$opt_link $2" ; shift ; shift ; goto top
+
+     case -debug
+        if $HP then
+           set optim=" -g "
+        else if $SUN then
+           setenv PARALLEL 2
+# Il faut rajouter l'option -dalign a -g pour pouvoir editer les liens
+# avec des programmes compiles avec -fast
+           set optim=" -g -dalign "
+           set optim90=" -fixed -g "
+           set optimtru90=" -free -g -C -dalign "
+        else if $CRAY then
+           set optim="$optim"" -g "
+           set optim90="$optim90"" -G1 "
+        else if $LINUX then
+           if ( $FC_LINUX == "pgf90" ) then
+             set optim="$optim"" -g -C -Mbounds "
+             set optim90="$optim90"" -g -C -Mbounds "
+             set optimtru90="$optimtru90"" -g -C -Mbounds "
+           else if ( $FC_LINUX == 'g95' ) then
+             set optim="$optim"" -g -fbounds-check "
+             set optim90="$optim90"" -g -fbounds-check "
+             set optimtru90="$optimtru90"" -g -fbounds-check "
+           else
+             echo 'compilateur linux non reconnu'
+             exit
+           endif
+        else 
+           echo pas d option debug predefinie pour cette machine
+           exit
+        endif
+        shift ; goto top
+
+     default
+        set code="$1" ; shift ; goto top
+
+   endsw
+endif
+
+########################################################################
+# Definition des clefs CPP
+########################################################################
+
+set cppflags=''
+
+if $X8BRODIE then
+  set cppflags="$cppflags -DNC_DOUBLE -DBLAS -DSGEMV=DGEMV -DSGEMM=DGEMM"
+endif
+
+if ( $io == ioipsl ) then
+   set cppflags="$cppflags -DCPP_IOIPSL"
+endif
+
+if ( "$physique" == 'nophys' ) then
+   set phys="L_PHY= LIBPHY="
+else
+   set cppflags="$cppflags -DCPP_PHYS"
+endif
+
+set link_veget=" "
+if ( "$veget" == 'true' ) then
+   set cppflags="$cppflags -DCPP_VEGET"
+   set link_veget=" -lsechiba -lparameters -lstomate -lorglob -lparallel"
+   if ( $XNEC || $X8BRODIE || $X6NEC) then
+      set link_veget=" -lsxsechiba -lsxparameters -lsxstomate -lsxorglob -lsxparallel"
+   endif
+endif
+
+if ( "$chimie" == 'CH4' ) then
+    set cppflags="$cppflags -DINCA -DINCA_CH4 "
+else if ( "$chimie" == 'CH4_AER' ) then
+    set cppflags="$cppflags -DINCA -DINCA_CH4 -DINCA_AER"
+else if ( "$chimie" == 'NMHC' ) then
+    set cppflags="$cppflags -DINCA -DINCA_NMHC "
+else if ( "$chimie" == 'NMHC_AER' ) then
+    set cppflags="$cppflags -DINCA -DINCA_NMHC -DINCA_AER"
+else if ( "$chimie" == 'AER' ) then
+    set cppflags="$cppflags -DINCA -DINCA_AER"
+else if ("$chimie" == 'GES' ) then
+    set cppflags="$cppflags -DINCA" 
+endif
+if ( "$chimie" == 'CH4' || "$chimie" == 'CH4_AER' || "$chimie" == 'NMHC' || "$chimie" == 'NMHC_AER' || "$chimie" == 'AER' || "$chimie" == 'GES' ) then
+#    set opt_dep="$opt_dep chimie" 
+    set libchimie=" -L$INCALIB -lchimie"
+    set opt_link="$opt_link  -L$INCALIB -lchimie"
+#    set libchimie="-lchimie"
+#    if ( $XNEC || $X6NEC || $X8BRODIE ) then
+#      set libchimie="-lsxchimie"
+#    endif
+endif
+    
+if ( "$couple" == 'true' ) then
+   set cppflags="$cppflags -DCPP_COUPLE"
+endif
+
+set FLAG_PARA=''
+if ( "$parallel" == 'true' ) then
+   set cppflags="$cppflags -DCPP_PARA"
+   set FLAG_PARA='par'
+endif
+
+set optim="$optim $cppflags"
+set optim90="$optim90 $cppflags"
+set optimtru90="$optimtru90 $cppflags"
+
+
+########################################################################
+# cas special sans physique
+########################################################################
+if ( "$physique" == 'nophys' ) then
+   set phys="L_PHY= LIBPHY="
+endif
+
+########################################################################
+# choix du nombre de traceur par defaut si il n'a pas ete choisi,
+# suivant la physique
+########################################################################
+
+if ( $ntrac == 0  ) then
+    if ( "$physique" == 'nophys' ) then
+        set ntrac=1
+    else if ( "$physique" == 'lmd' ) then
+        set ntrac=2
+    else if ( "$physique" == 'lmd_test_li' ) then
+        set ntrac=2
+    else if ( "$physique" == 'ec' ) then
+        set ntrac=1
+    else
+        set ntrac = 1
+    endif
+endif
+
+########################################################################
+#subtilites sur le nom de la librairie
+########################################################################
+
+\rm -f tmp ; touch tmp
+\rm -f tmp90 ; touch tmp90
+foreach i ( $optim )
+   echo $i | sed -e 's/\"//g' -e "s/\'//g" -e 's/-//g'  >> tmp
+end
+set suf=
+foreach i ( `sort tmp | uniq ` )
+   set suf=$suf$i
+end
+if ( ! $IBM ) then
+   set nomlib="$nomlib$suf"
+endif
+if ( $DEC ) then
+   set nomlib=DEC
+endif
+if ( $IBM ) then
+   set dim=`echo $dim | sed -en 's/[^0-9]/ /g'`
+   set dim_=`echo $dim | sed -en 's/[^0-9]/_/g'`
+else if ( $SUN ) then
+   set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` 
+   set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'`
+else
+   set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'`
+   set dim=`echo $dim | sed -e 's/[^0-9]/ /g'`
+endif
+set nomlib=${nomlib}${physique}_${dim_}_t${ntrac}_$grille
+## M-A-F nomlib trop long sur CRAY pour ar
+if ( $CRAY ) then
+    set nomlib=F90_${dim_}_t${ntrac}
+endif
+if ( $NEC || $XNEC || $X6NEC || $X8BRODIE ) then
+    set nomlib=F90_${dim_}_t${ntrac}_'phy'${physique}${FLAG_PARA}
+endif
+echo calcul de la dimension
+set dimc=`echo $dim | wc -w`
+
+if ( "$dimc" == "2" ) then
+set include="$include "'-I$(LIBF)/dyn2d '
+set dimh=$dim
+else
+set include="$include "'-I$(LIBF)/dyn3d${FLAG_PARA} '
+set dimh=`echo $dim | awk ' { print $1 "." $2 } '`
+endif
+echo $dimc
+
+########################################################################
+# path pour les #include
+########################################################################
+
+if ( $XNEC ) then
+  set include="$include -I$NCDFINC -I$IOIPSLDIR"
+else
+  set include="$include -I$NCDFINC -I$IOIPSLDIR"
+endif
+echo $include
+
+########################################################################
+# Gestion des dimensions du modele.
+# on cree ou remplace le fichier des dimensions/nombre de traceur
+########################################################################
+
+cd $libf/grid
+if ( -f dimensions.h ) then
+echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs'
+echo "Attendez que la premiere compilation soit terminee pour relancer la suivante."
+echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs,"
+echo  vous pouvez continuer en repondant oui.
+echo "Voulez-vous vraiment continuer?"
+if ( $< == "oui" ) then
+\rm -f $libf/grid/dimensions.h
+else
+exit
+endif
+endif
+
+cd dimension
+./makdim $ntrac $dim
+cat $libf/grid/dimensions.h
+
+cd $LMDGCM
+set libo=$libo/$nomlib
+if ( ! -d $libo )  then
+   mkdir $libo
+   cd $model
+endif
+
+########################################################################
+# Differentes dynamiques (3d, 2d, 1d)
+########################################################################
+
+set dimension=`echo $dim | wc -w`
+echo dimension $dimension
+if ( $dimension == 1 ) then
+echo pas de dynamique
+set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique "
+endif
+endif
+cd $model
+if ( $dimension == 3 ) then
+cd libf/grid
+\rm fxyprim.h
+cp -p fxy_${grille}.h fxyprim.h
+endif
+
+######################################################################
+#   Traitement special pour le nouveau rayonnement de Laurent Li.
+######################################################################
+
+if ( -f $libf/phy$physique/raddim.h ) then
+ if ( -f $libf/phy$physique/raddim.$dimh.h ) then
+  \rm -f $libf/phy$physique/raddim.h
+  cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h
+  echo $libf/phy$physique/raddim.$dimh.h 
+  cat $libf/phy$physique/raddim.$dimh.h 
+  cat $libf/phy$physique/raddim.h
+ else
+  echo On peut diminuer la taille de l executable en creant
+  echo le fichier $libf/phy$physique/raddim.$dimh.h
+  \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h
+ endif
+endif
+
+######################################################################
+# Gestion du filtre qui n'existe qu'en 3d.
+######################################################################
+
+if ( `expr $dimc \> 2` == 1 ) then
+   set filtre="FILTRE=$filtre"
+else
+   set filtre="FILTRE= L_FILTRE= "
+endif
+echo MACRO FILTRE $filtre
+
+echo $dimc
+
+########################################################################
+#  Avant de lancer le make, on recree le makefile si necessaire
+########################################################################
+########################################################################
+# c'est a dire dans 3 cas:
+# 1. si la liste des fichiers .F et .h a ete modifiee depuis la
+#    derniere creation du makefile
+# 2. si le fichier contenant cette liste "liste_des_sources"
+#    n'existe pas.
+# 3. Si le makefile n'existe pas.
+########################################################################
+##########################################
+# On adapte d'abord certains include à F90
+##########################################
+##########################################
+cd $model
+find libf -name '*.[Fh]' -print >! tmp77
+find libf -name '*.[Fh]' -exec egrep -i " *use *ioipsl" {} \; -print >! tmp90
+find libf -name '*.[Fh]90' -print >> tmp90
+
+if (    `diff tmp77 liste_des_sources_f77 | wc -w` \
+     || `diff tmp90 liste_des_sources_f90 | wc -w` \
+     || ! -f makefile \
+     || ! -f liste_des_sources_f90 \
+     || ! -f liste_des_sources_f77 ) then
+        echo les fichiers suivants ont ete crees ou detruits
+        echo ou les fichiers suivants sont passes ou ne sont plus en Fortran 90
+        diff liste_des_sources_f77 tmp77
+        diff liste_des_sources_f90 tmp90
+        \cp tmp77 liste_des_sources_f77
+        \cp tmp90 liste_des_sources_f90
+        echo On recree le makefile
+        ./create_make_gcm >! tmp
+        \mv tmp makefile
+        echo Nouveau makefile cree.
+endif
+
+########################################################################
+#  Execution de la comande make
+########################################################################
+
+echo PHYSIQUE $phys
+echo dynamique $dyn $dimension
+echo OPTIM="$optim" $filtre LIBO=$libo $dyn PHYS=$phys DIM=$dimc PROG=$code
+echo PATH pour les fichiers INCLUDE $include
+echo OPLINK="$oplink"
+
+#################
+if $HP then
+#################
+   set f77='fort77 +OP'
+   set f90='jensaisrien'
+   set opt_link="$opt_link -lm"
+#################
+else  if $VPP then
+#################
+   set f77=frt
+   set f90=$f77
+   if ($couple == true) then
+     set opt_link="-Wg,-c $MODIPSLDIR/liboasis2.4_mpi2.a /usr/lang/mpi2/lib64/libmpi.a /usr/lang/mpi2/lib64/libmp.a -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a"
+     set oplink="-Wl,-t,-P,-dy "
+   else
+     set opt_link="-Wg,-c -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a"
+     set oplink="-Wl,-t,-dy "
+   endif
+   if ($veget == true) then
+     set opt_link="$opt_link $link_veget -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a"
+   endif
+#################
+else if $CRAY then
+#################
+   set f77=f90
+   set f90=f90
+#################
+else if $LINUX then
+#################
+#   set f77=pgf90
+#   set f90=pgf90
+   set f77=$FC_LINUX
+   set f90=$FC_LINUX
+   if ( $FC_LINUX == 'pgf90' ) then
+   set opt_link=" -L$MODIPSLDIR $link_veget -L$NCDFLIB -lioipsl -lnetcdf "
+   else if ($FC_LINUX == 'g95') then
+     set opt_link="-L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf -lioipsl -lnetcdf "
+   else
+     set opt_link=" "
+   endif
+#################
+else if $SUN then
+#################
+   set f77=f90
+   set f90=f90
+   set opt_link="-lf77compat -L$MODIPSLDIR $link_veget -lioipsl -L$NCDFLIB -lnetcdf "
+#################
+else if $NEC then
+#################
+   set f77=f90 -ftrace
+   set f90=f90 -ftrace
+   set opt_link="-L$MODIPSLDIR"
+   if ($veget == true) then
+     set opt_link="$opt_link $link_veget"
+   endif
+   if ($couple == true) then
+     set opt_link="$opt_link -lioipsl -loasis2.4_mpi2 -float0 -ew -P static $NCDFLIB "
+   else
+     set opt_link="$opt_link -L$MODIPSLDIR -lioipsl -float0 -ew -P static $NCDFLIB "
+   endif
+   set mod_loc_dir="./"
+#################
+else if $XNEC then
+#################
+   set f77="sxmpif90 -ftrace"
+   set f90="sxmpif90 -ftrace"
+   if $MODIPSL then
+     set opt_link="-L$MODIPSLDIR"
+     if ($veget == true) then
+       set opt_link="$opt_link $link_veget"
+     endif
+     if ($couple == true) then
+       if ($psmile == true) then
+       set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB "
+       else
+       set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB "
+       endif
+     else
+       set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB "
+     endif
+   else
+     if ($couple == true) then
+       set opt_link="-L$MODIPSLDIR"
+       set opt_link="$opt_link $link_veget -lsxioipsl -loasis2.4_mpi2 -float0 $optdbl -P static $NCDFLIB "
+     else
+       set opt_link=" -C hopt -float0 $optdbl -P static -L$MODIPSLDIR $link_veget -lsxioipsl $NCDFLIB "
+     endif
+   endif
+   set mod_loc_dir="./"
+##################
+else if $X6NEC then
+##################
+   set f77=sxmpif90
+   set f90=sxmpif90
+   if $MODIPSL then
+     set opt_link="$opt_link -L$MODIPSLDIR"
+     if ($veget == true) then
+       set opt_link="$opt_link $link_veget"
+     endif
+     if ($couple == true) then
+	if ($psmile == true) then
+	set opt_link="$opt_link -lsxioipsl -float0 -size_t64 $optdbl -P static $NCDFLIB "
+	else
+	set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 -size_t64 $optdbl -P static $NCDFLIB "
+	endif
+     else
+       set opt_link="$opt_link -lsxioipsl -float0 -size_t64 $optdbl -P static $NCDFLIB "
+     endif
+   else
+#     set opt_link=" -float0 -size_t64 $optdbl -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NCDFLIB "
+     set opt_link=" $opt_link -float0 -size_t64 $optdbl -P static -L$MODIPSLDIR -lsxioipsl $NCDFLIB "
+
+   endif
+   set mod_loc_dir="./"
+##################
+else if $X8BRODIE then
+##################
+   set f77=sxmpif90
+   set f90=sxmpif90
+   if $MODIPSL then
+     set opt_link="$opt_link -float0 -Wf,-A dbl4 -L$MODIPSLDIR -lblas"
+     if ($veget == true) then
+       set opt_link="$opt_link $link_veget"
+     endif
+     if ($couple == true) then
+       set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB "
+     else
+       set opt_link="$opt_link -lsxioipsl -float0 $optdbl -P static $NCDFLIB "
+     endif
+   else
+#     set opt_link=" -float0 $optdbl -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NCDFLIB "
+     set opt_link=" -float0 $optdbl -P static -L$MODIPSLDIR -lsxioipsl $NCDFLIB -lblas"
+
+   endif
+   set mod_loc_dir="./"
+#################
+else
+#################
+   set f77=f77
+   set f90=f90
+endif
+
+cd $model
+
+if $VPP then
+set make="gmake RANLIB=ls"
+else if $CRAY then
+set make="make RANLIB=ls"
+else if $NEC then
+set make="make RANLIB=ls"
+else if $LINUX then
+set make="make -k RANLIB=ranlib"
+else if $XNEC then
+set make="gmake RANLIB=ls"
+else if $X6NEC then
+set make="gmake RANLIB=ls"
+else if $X8BRODIE then
+set make="gmake RANLIB=ls"
+else
+set make="make RANLIB=ranlib"
+endif
+
+
+
+
+#
+# etat0_netcdf a besoin d'info de la physique
+# A revoir
+set include="$include"' -I$(LIBF)/phy'"$physique"
+#
+# le programme principal create_limit a besoin de l'info du module
+# startvar: on met donc libo dans les include pour Nec
+set include="$include"' -I$(LIBO)'
+
+
+#################################################################
+# Execution de la comande make... ENFIN!
+#################################################################
+
+if $VPP then
+  set optim90=" $optim90 -Am -M$libo"
+  set optimtru90="$optim90"
+ \cp $IOIPSLDIR/*.mod $libo
+else if $SUN then
+ set optim90=" $optim90 -M$libo -M$MODIPSLDIR "
+ set optimtru90=" $optimtru90 -M$libo -M$MODIPSLDIR "
+ set optim="$optim90"
+ \cp $IOIPSLDIR/*.mod $libo
+else if $NEC then
+ set optim90=" $optim90 -I$libo "
+else if $XNEC then
+ set optim90=" $optim90 -I$libo "
+ set optimtru90=" $optimtru90 -I$libo "
+else if $X6NEC then
+ set optim90=" $optim90 -I$libo "
+ set optimtru90=" $optimtru90 -I$libo "
+else if $X8BRODIE then
+ set optim90=" $optim90 -I$libo "
+ set optimtru90=" $optimtru90 -I$libo "
+else if $LINUX then
+ if ( $FC_LINUX == "pgf90" ) then
+   set optimtru90=" $optimtru90 -module $libo "
+   set optim90=" $optim90 -module $libo "
+ else if ( $FC_LINUX == 'g95' ) then
+   set optimtru90=" $optimtru90 -fmod=$libo  "
+   set optim90=" $optim90 -fmod=$libo  "
+ endif
+ set optim="$optim90"
+ set mod_loc_dir=$libo
+# \cp /d3/fairhead/sechiba/ioipsl/*.mod $libo
+# \cp $IOIPSLDIR/*.mod $libo
+endif
+
+set link="$f90 $optim90"
+
+set ar=ar
+
+if $XNEC then
+  set link="sxld $opt_link"
+  set link="$f90 "
+#  set ar=sxar
+else if $X6NEC then
+  set link="sxld $opt_link"
+  set link="$f90 -Wl,-hlib_cyclic "
+else if $X8BRODIE then
+  set link="sxld $opt_link"
+  set link="$f90 -Wl,-hlib_cyclic "
+endif
+
+
+cd $localdir
+
+echo $make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+OPTIMTRU90="$optimtru90" \
+OPTIM="$optim$optimbis" \
+INCLUDE="$include" \
+$filtre \
+LIBO=$libo \
+$dyn \
+$phys \
+DIM=$dimc \
+FLAG_PARA="$FLAG_PARA"\
+L_ADJNT="$adjnt" \
+L_CHIMIE="$libchimie" \
+LOCAL_DIR="$localdir"  \
+F77="$f77" \
+F90="$f90" \
+OPLINK="$oplink" \
+LINK="$link" \
+GCM="$LMDGCM" \
+MOD_LOC_DIR=$mod_loc_dir \
+MOD_SUFFIX=$mod_suffix \
+AR=$ar \
+PROG=$code
+
+$make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+OPTIMTRU90="$optimtru90" \
+OPTIM="$optim$optimbis" \
+INCLUDE="$include" \
+$filtre \
+LIBO=$libo \
+$dyn \
+$phys \
+DIM=$dimc \
+FLAG_PARA="$FLAG_PARA"\
+L_ADJNT="$adjnt" \
+L_CHIMIE="$libchimie" \
+LOCAL_DIR="$localdir"  \
+F77="$f77" \
+F90="$f90" \
+OPLINK="$oplink" \
+LINK="$link" \
+GCM="$LMDGCM" \
+MOD_LOC_DIR=$mod_loc_dir \
+MOD_SUFFIX=$mod_suffix \
+AR=$ar \
+PROG=$code
+
+\rm -f $libf/grid/dimensions.h
Index: LMDZ4/tags/LF_20080728/makegcm_fcm
===================================================================
--- LMDZ4/tags/LF_20080728/makegcm_fcm	(revision 984)
+++ LMDZ4/tags/LF_20080728/makegcm_fcm	(revision 984)
@@ -0,0 +1,359 @@
+#!/bin/csh
+#
+# $Header$
+#
+# FH : on ne crée plus le fichier arch.mk qui est supposé exister par
+# FH : ailleurs.
+# FH : ultérieurement, ce fichier sera pré-existant pour une série
+# FH : de configurations en versions optimisées et debug qui seront
+# FH : liés (ln -s) avec arch.mk en fonction de l'architecture.
+# FH : Pour le moment, cette version est en test et on peut créer les
+# FH : arch.mk en lançant une première fois makegcm7.
+#
+set verbose echo
+########################################################################
+# options par defaut pour la commande make
+########################################################################
+
+set dim="96x72x19"
+set physique=lmd
+set ntrac = 4
+set filtre=filtrez
+set grille=reg
+set couple=false
+set veget=false
+set chimie=false
+set parallel=false
+set io=ioipsl
+set LIBPREFIX=""
+
+set LMDGCM=`/bin/pwd`
+set LIBOGCM=$LMDGCM/libo
+set LIBFGCM=$LMDGCM/libf
+
+########################################################################
+#  Quelques initialisations de variables du shell.
+########################################################################
+
+set CPP_KEY="" 
+set INCLUDE=""
+set LIB=""
+set adjnt=""
+
+
+########################################################################
+# lecture des options de mymake
+########################################################################
+
+top:
+if ($#argv > 0) then
+    switch ($1:q)
+
+    case -h:
+cat <<fin
+manuel complet sur http://...
+Usage :
+makegcm
+[-h]                   : manuel abrégé
+[-d [[IMx]JMx]LM]      : IM, JM, LM sont les dims en x, y, z (def: $dim)
+[-t NTRAC]             : nombre de traceurs (def: 4)
+[-p PHYS]              : compilation avec la physique libf/phyPHYS, (def: lmd)
+[-debug]               : compile avec options debug.
+[-c false/MPI1/MPI2]   : couplé océan : MPI1/MPI2/false (def: false)
+[-v false/true]        : avec ou sans végétation (def: false)
+[-chimie SCHEMA/false] : nom du schéma chimique ou false (def)
+[-parallel true/false] : parallelisation, en développement (def: false)
+[-g GRI]               : conf. grille dans dyn3d/GRI_xy.h\
+                         (def: reg inclue un zoom)
+[-io IO]               : choix d'une librairie I/O, experts (def: ioipsl)
+[-include INCLUDES]    : variables supplementaires pour include cpp, experts.
+[-adjnt]               : adjoint, a remettre en route ...
+[-filtre NOMFILTRE]    : prend le filtre dans libf/NOMFILTRE (def: filtrez)
+[-link LINKS]          : liens optionels avec d'autres librairies
+[-m arch]              : nom de l'architecture cible
+fin
+	exit
+
+    case -d:
+        set dim=$2 ; shift ; shift ; goto top
+                        
+    case -O:
+        echo "option obsolete dans cette version intermediaire de makegcm"
+	exit
+
+     case -p
+        set physique="$2" ;  shift ; shift ; goto top
+
+     case -g
+        set grille="$2" ; shift ; shift ; goto top
+
+     case -c
+	set couple="$2" ; shift ; shift ; goto top
+
+     case -io
+        set io="$2" ; shift ; shift ; goto top
+
+     case -v
+        set veget="$2" ; shift ; shift ; goto top
+
+     case -chimie
+	set chimie="$2" ; shift ; shift ; goto top
+
+     case -parallel
+        set parallel="$2" ; shift ; shift ; goto top
+  
+     case -t
+        set ntrac=$2 ; shift ; shift ; goto top
+
+     case -include
+        set INCLUDE="$INCLUDE -I$2" ; shift ; shift ; goto top
+
+     case -adjnt
+	echo 'otpion a reactiver ';exit
+        set opt_dep="$opt_dep adjnt" ; set adjnt="-ladjnt -ldyn3d "
+        set optim="$optim -Dadj" ; shift ; goto top
+
+
+     case -filtre
+        set filtre=$2 ; shift ; shift ; goto top
+
+     case -link
+        set LIB="$LIB $2" ; shift ; shift ; goto top
+
+     case -m
+       set arch=$2 ; shift ; shift ; goto top
+       
+     case -debug
+        echo 'option a reactiver' ; exit
+
+     default
+        set code="$1" ; shift ; goto top
+
+   endsw
+endif
+
+
+###############################################################
+# lecture des chemins propres à l'architecture  de la machine #
+###############################################################
+
+rm -f ./arch.path
+ln -s ./machine/arch-${arch}.path ./arch.path
+source arch.path
+
+########################################################################
+# Definition des clefs CPP, des chemins des includes et modules
+#  et des libraries
+########################################################################
+
+
+if ( "$physique" == 'nophys' ) then
+   
+else
+   set CPP_KEY="$CPP_KEY CPP_PHYS"
+endif
+
+
+if ( "$chimie" == 'AER' ) then
+    set CPP_KEY="$CPP_KEY INCA INCA_AER"
+    set INCLUDE="$INCLUDE -I${INCA_INCDIR}"
+    set LIB="$LIB -L${INCA_LIBDIR} -lchimie" 
+else if  ( "$chimie" == 'CH4' ) then
+    set CPP_KEY="$CPP_KEY INCA INCA_CH4"
+    set INCLUDE="$INCLUDE -I${INCA_INCDIR}"
+    set LIB="$LIB -L${INCA_LIBDIR} -lchimie" 
+else if  ( "$chimie" == 'CH4_AER' ) then
+    set CPP_KEY="$CPP_KEY INCA INCA_AER INCA_CH4"
+    set INCLUDE="$INCLUDE -I${INCA_INCDIR}"
+    set LIB="$LIB -L${INCA_LIBDIR} -lchimie" 
+else if  ( "$chimie" == 'NMHC' ) then
+    set CPP_KEY="$CPP_KEY INCA INCA_NMHC"
+    set INCLUDE="$INCLUDE -I${INCA_INCDIR}"
+    set LIB="$LIB -L${INCA_LIBDIR} -lchimie" 
+else if  ( "$chimie" == 'NMHC_AER' ) then
+    set CPP_KEY="$CPP_KEY INCA INCA_AER INCA_NMHC"
+    set INCLUDE="$INCLUDE -I${INCA_INCDIR}"
+    set LIB="$LIB -L${INCA_LIBDIR} -lchimie" 
+else if ( "$chimie" == 'GES' ) then
+    set CPP_KEY="$CPP_KEY INCA"
+    set INCLUDE="$INCLUDE -I${INCA_INCDIR}"
+    set LIB="$LIB -L${INCA_LIBDIR} -lchimie" 
+endif
+
+if ( "$couple" != 'false' ) then
+   set CPP_KEY="$CPP_KEY CPP_COUPLE"
+   set INCLUDE="$INCLUDE -I${OASIS_INCDIR}"
+   set LIB="$LIB -L${OASIS_LIBDIR} -lpsmile.${couple} -lmpp_io"
+endif
+
+if ( "$parallel" == 'true' ) then
+   set CPP_KEY="$CPP_KEY CPP_PARA"
+endif
+
+if ( "$veget" == 'true' ) then
+   set CPP_KEY="$CPP_KEY CPP_VEGET"
+   set INCLUDE="${INCLUDE} -I${ORCH_INCDIR}"
+   set LIB="${LIB} -L${ORCH_LIBDIR} -l${LIBPREFIX}sechiba -l${LIBPREFIX}parameters -l${LIBPREFIX}stomate -l${LIBPREFIX}parallel -l${LIBPREFIX}orglob"
+endif
+
+if ( $io == ioipsl ) then
+   set CPP_KEY="$CPP_KEY CPP_IOIPSL"
+   set INCLUDE="$INCLUDE -I${IOIPSL_INCDIR}"
+   set LIB="$LIB -L${IOIPSL_LIBDIR} -l${LIBPREFIX}ioipsl"
+endif
+
+set INCLUDE="$INCLUDE -I${NETCDF_INCDIR}"
+set LIB="$LIB -L${NETCDF_LIBDIR} -lnetcdf"
+
+
+########################################################################
+# choix du nombre de traceur par defaut si il n'a pas ete choisi,
+# suivant la physique
+########################################################################
+
+if ( $ntrac == 0  ) then
+    if ( "$physique" == 'nophys' ) then
+        set ntrac=1
+    else if ( "$physique" == 'lmd' ) then
+        set ntrac=2
+    else if ( "$physique" == 'lmd_test_li' ) then
+        set ntrac=2
+    else if ( "$physique" == 'ec' ) then
+        set ntrac=1
+    else
+        set ntrac = 1
+    endif
+endif
+
+
+########################################################################
+# calcul du nombre de dimensions
+########################################################################
+
+
+set dim_full=$dim
+set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` 
+set dimc=`echo $dim | wc -w`
+
+echo calcul de la dimension
+echo dim $dim
+echo dimc $dimc
+
+
+########################################################################
+# Gestion des dimensions du modele.
+# on cree ou remplace le fichier des dimensions/nombre de traceur
+########################################################################
+
+cd $LIBFGCM/grid/dimension
+./makdim $ntrac $dim
+cat $LIBFGCM/grid/dimensions.h
+cd $LMDGCM
+
+
+########################################################################
+# Differentes dynamiques (3d, 2d, 1d)
+########################################################################
+
+set dimension=`echo $dim | wc -w`
+echo dimension $dimension
+
+if ( $dimension != 3 ) then
+  echo "Probleme dans les dimensions de la dynamique !!"
+  echo "Non reactive pour l'instant !!!"
+endif
+
+if ( $dimension == 3 ) then
+  cd $LIBFGCM/grid
+  \rm fxyprim.h
+  cp -p fxy_${grille}.h fxyprim.h
+endif
+
+######################################################################
+#   Traitement special pour le nouveau rayonnement de Laurent Li.
+#   ---> YM desactive pour le traitemement en parallele
+######################################################################
+
+#if ( -f $libf/phy$physique/raddim.h ) then
+# if ( -f $libf/phy$physique/raddim.$dimh.h ) then
+#  \rm -f $libf/phy$physique/raddim.h
+#  cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h
+#  echo $libf/phy$physique/raddim.$dimh.h 
+#  cat $libf/phy$physique/raddim.h
+# else
+#  echo On peut diminuer la taille de l executable en creant
+#  echo le fichier $libf/phy$physique/raddim.$dimh.h
+#  \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h
+# endif
+#endif
+
+######################################################################
+# Gestion du filtre qui n'existe qu'en 3d.
+######################################################################
+
+if ( `expr $dimc \> 2` == 1 ) then
+   set filtre="FILTRE=$filtre"
+else
+   set filtre="FILTRE= L_FILTRE= "
+endif
+echo MACRO FILTRE $filtre
+
+echo $dimc
+
+
+
+######################################################################
+# Creation du suffixe de la configuration
+######################################################################
+
+
+set SUFF_NAME=_${dim_full}
+set SUFF_NAME=${SUFF_NAME}_t${ntrac}_phy${physique}
+
+if ( "$parallel" == 'true' ) then
+  set SUFF_NAME=${SUFF_NAME}_para
+  set DYN=dyn${dimc}dpar
+else
+  set SUFF_NAME=${SUFF_NAME}_seq
+  set DYN=dyn${dimc}d
+endif
+
+if ( $veget == "true" ) then
+  set SUFF_NAME=${SUFF_NAME}_orch
+endif
+
+if ( $couple != "false" ) then
+  set SUFF_NAME=${SUFF_NAME}_couple
+endif
+
+if ( $chimie == "true" ) then
+  set SUFF_NAME=${SUFF_NAME}_inca
+endif
+
+cd $LMDGCM
+set config_fcm="config.fcm"
+rm -f $config_fcm
+touch $config_fcm
+rm -f bin/${code}${SUFF_NAME}.e
+rm -f arch.fcm
+
+echo "%ARCH          $arch"          >> $config_fcm
+echo "%INCDIR        $INCLUDE"       >> $config_fcm 
+echo "%LIB           $LIB"           >> $config_fcm
+echo "%ROOT_PATH     $PWD"           >> $config_fcm
+echo "%LIBF          $LIBFGCM"       >> $config_fcm
+echo "%LIBO          $LIBOGCM"       >> $config_fcm
+echo "%DYN           $DYN"           >> $config_fcm
+echo "%PHYS          phy${physique}" >> $config_fcm
+echo "%CPP_KEY       $CPP_KEY"       >> $config_fcm
+echo "%EXEC          $code"          >> $config_fcm
+echo "%SUFF_NAME     $SUFF_NAME"     >> $config_fcm
+
+ln -s machine/arch-${arch}.fcm arch.fcm
+./build_gcm
+
+rm -f tmp_src
+rm -f config
+ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config config
+ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config/tmp tmp_src
+#\rm -f $libf/grid/dimensions.h
Index: LMDZ4/tags/LF_20080728/offline.def
===================================================================
--- LMDZ4/tags/LF_20080728/offline.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/offline.def	(revision 984)
@@ -0,0 +1,12 @@
+#
+# $Header$
+#
+T
+4
+T
+-2.
+48.1
+1
+T
+6
+2
Index: LMDZ4/tags/LF_20080728/orchidee.def
===================================================================
--- LMDZ4/tags/LF_20080728/orchidee.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/orchidee.def	(revision 984)
@@ -0,0 +1,46 @@
+#
+# $Header$
+#
+#
+# SECHIBA
+#
+STOMATE_OK_CO2=FALSE
+# STOMATE_OK_STOMATE is not set
+# STOMATE_OK_DGVM is not set
+# STOMATE_WATCHOUT is not set
+#SECHIBA_restart_in=default
+SECHIBA_restart_in=start_sech.nc
+SECHIBA_rest_out=sechiba_rest.nc
+SECHIBA_reset_time=y
+SECHIBA_reset_time is not set
+OUTPUT_FILE=sechiba_out.nc
+WRITE_STEP=2592000
+SECHIBA_HISTLEVEL=10
+STOMATE_OUTPUT_FILE=stomate_history.nc
+STOMATE_HIST_DT=10.
+STOMATE_HISTLEVEL=0
+SECHIBA_DAY=0.0
+SECHIBA_ZCANOP=0.5
+DT_SLOW=86400.
+# IMPOSE_VEG is not set
+VEGETATION_FILE=carteveg5km.nc
+DIFFUCO_LEAFCI=233.
+CONDVEG_SNOWA=default
+# IMPOSE_AZE is not set
+SOILALB_FILE=soils_param.nc
+SOILTYPE_FILE=soils_param.nc 
+ENERBIL_TSURF=280.
+HYDROL_SNOW=0.0
+HYDROL_SNOWAGE=0.0
+HYDROL_SNOWICE=0.0
+HYDROL_SNOWICEAGE=0.0
+HYDROL_HDRY=1.0
+HYDROL_HUMR=1.0
+HYDROL_BQSB=default
+HYDROL_GQSB=0.0
+HYDROL_DSG=0.0
+HYDROL_DSP=default
+HYDROL_QSV=0.0
+THERMOSOIL_TPRO=280.
+RIVER_ROUTING=y
+ROUTING_FILE=routing.nc
Index: LMDZ4/tags/LF_20080728/physiq.def
===================================================================
--- LMDZ4/tags/LF_20080728/physiq.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/physiq.def	(revision 984)
@@ -0,0 +1,83 @@
+#
+# $Header$
+#
+
+OCEAN=force 
+VEGET=y
+OK_journe=n
+OK_mensuel=y
+OK_instan=n
+if_ebil=0
+#
+# parametres KE
+#
+epmax = .99
+ok_adj_ema = n
+iflag_clw = 1
+# 
+# parametres nuages
+#
+cld_lc_lsc = 0.00026
+cld_lc_con = 0.00026
+cld_tau_lsc = 3600.
+cld_tau_con = 3600.
+ffallv_lsc = 1.
+ffallv_con = 1.
+coef_eva = 0.00002
+reevap_ice = y
+iflag_cldcon = 3
+iflag_pdf = 1
+fact_cldcon = 1.
+#facttemps = 1.e-4
+facttemps = 0.0001
+ok_newmicro = y
+ratqsbas = 0.005
+ratqshaut = 0.33
+rad_froid = 35
+rad_chau1=12
+rad_chau2=11
+#ksta_ter=1.e-7
+ksta_ter=0.0000001
+#
+# parametres outputs
+#
+#niveau de sortie "hf" lev_histhf avec
+# - lev_histhf=3 => defaut
+# - lev_histhf=4 => histhf3d.nc champs 3d niveaux modele
+lev_histhf=3
+#niveau de sortie "day" lev_histday
+# - lev_histday=2 => defaut
+# - lev_histday=3 => + champs 3D => F. Lott
+# - lev_histday=4 => + champs sous-surfaces
+lev_histday=2
+#niveau de sortie "mth" lev_histmth avec
+# - lev_histmth=2 => defaut
+# - lev_histmth=3 => albedo, rugosite sous-surfaces
+# - lev_histmth=4 => champs tendances 3d
+lev_histmth=2
+#
+# parametres climatique
+#
+R_ecc = 0.016715
+R_peri = 102.7
+R_incl = 23.441
+solaire = 1365.
+co2_ppm = 348.
+CH4_ppb = 1650.
+N2O_ppb = 306.
+CFC11_ppt = 280.
+CFC12_ppt = 484.
+#
+# parametres simulateur ISCCP
+#
+top_height = 3
+#overlap = 1, 2 ou 3
+overlap = 3
+#cdmmax
+#cdmmax = 2.5E-3
+cdmmax = 0.0025
+#cdhmax
+#cdhmax = 2.0E-3
+cdhmax = 0.002
+iflag_pbl = 1
+iflag_thermals = 0
Index: LMDZ4/tags/LF_20080728/run.def
===================================================================
--- LMDZ4/tags/LF_20080728/run.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/run.def	(revision 984)
@@ -0,0 +1,20 @@
+#
+# $Header$
+#
+INCLUDEDEF=physiq.def
+INCLUDEDEF=gcm.def
+INCLUDEDEF=orchidee.def
+## Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici )
+dayref=1
+##  Annee de l'etat  initial (   avec  4  chiffres   )
+anneeref=1979
+## Nombre de jours d'integration
+nday=1
+## periode de sortie des variables de controle (en pas)
+iconser=5
+## periode d'ecriture du fichier histoire (en jour)
+iecri=1
+## periode de stockage fichier histmoy (en jour)
+periodav=1.
+## unite de sortie des impressions
+lunout=7
Index: LMDZ4/tags/LF_20080728/traceur.def
===================================================================
--- LMDZ4/tags/LF_20080728/traceur.def	(revision 984)
+++ LMDZ4/tags/LF_20080728/traceur.def	(revision 984)
@@ -0,0 +1,5 @@
+4
+14 14 H2Ov
+10 10 H2Ol
+10 10 RN
+10 10 PB
